diff options
| author | Shashank | 2017-05-29 12:40:26 +0530 |
|---|---|---|
| committer | Shashank | 2017-05-29 12:40:26 +0530 |
| commit | 0345245e860375a32c9a437c4a9d9cae807134e9 (patch) | |
| tree | ad51ecbfa7bcd3cc5f09834f1bb8c08feaa526a4 /modules/cacsd/src | |
| download | scilab_for_xcos_on_cloud-0345245e860375a32c9a437c4a9d9cae807134e9.tar.gz scilab_for_xcos_on_cloud-0345245e860375a32c9a437c4a9d9cae807134e9.tar.bz2 scilab_for_xcos_on_cloud-0345245e860375a32c9a437c4a9d9cae807134e9.zip | |
CMSCOPE changed
Diffstat (limited to 'modules/cacsd/src')
470 files changed, 68140 insertions, 0 deletions
diff --git a/modules/cacsd/src/c/Cacsd_f_Import.def b/modules/cacsd/src/c/Cacsd_f_Import.def new file mode 100755 index 000000000..de5f5fbe3 --- /dev/null +++ b/modules/cacsd/src/c/Cacsd_f_Import.def @@ -0,0 +1,32 @@ +LIBRARY cacsd_f.dll + + +EXPORTS +; --------------------------------------- +; cacsd_f +; --------------------------------------- +intricc_ +scisylv_ +scilyap_ +intlinmeq_ +intdhinf_ +inthinf_ +intricc2_ +intmucomp_ +findbd_ +sorder_ +sident_ +sciarl2_ +intereduc_ +scifreq_ +intfstair_ +scigschur_ +scigspec_ +scildiv_ +sciltitr_ +scippol_ +intzb03od_ +intmb03od_ +sciresidu_ +scirtitr_ +scitzer_ diff --git a/modules/cacsd/src/c/DllmainCacsd.c b/modules/cacsd/src/c/DllmainCacsd.c new file mode 100755 index 000000000..7a46b8c7a --- /dev/null +++ b/modules/cacsd/src/c/DllmainCacsd.c @@ -0,0 +1,63 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2010 - DIGITEO - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +#include <windows.h> +#include "machine.h" +/*--------------------------------------------------------------------------*/ +#pragma comment(lib,"../../../../bin/libintl.lib") +#pragma comment(lib,"../../../../bin/blasplus.lib") +#pragma comment(lib,"../../../../bin/lapack.lib") +/*--------------------------------------------------------------------------*/ +/* We force fortran COMMON definitions */ + +__declspec(dllexport) struct +{ + int io, info, ll; +} C2F(sortie); + +__declspec(dllexport) struct +{ + int nall1; +} C2F(comall); + +__declspec(dllexport) struct +{ + double t; +} C2F(temps); + +__declspec(dllexport) struct +{ + double gnrm; +} C2F(no2f); + +__declspec(dllexport) struct +{ + int info, i1; +} C2F(arl2c); +/*--------------------------------------------------------------------------*/ +int WINAPI DllMain (HINSTANCE hInstance , DWORD reason, PVOID pvReserved) +{ + switch (reason) + { + case DLL_PROCESS_ATTACH: + break; + case DLL_PROCESS_DETACH: + break; + case DLL_THREAD_ATTACH: + break; + case DLL_THREAD_DETACH: + break; + } + return 1; +} +/*--------------------------------------------------------------------------*/ + diff --git a/modules/cacsd/src/c/Linpack_f_Import.def b/modules/cacsd/src/c/Linpack_f_Import.def new file mode 100755 index 000000000..964f31907 --- /dev/null +++ b/modules/cacsd/src/c/Linpack_f_Import.def @@ -0,0 +1,8 @@ +LIBRARY linpack_f.dll + + +EXPORTS +; --------------------------------------- +; linpack_f +; --------------------------------------- +icopy_ diff --git a/modules/cacsd/src/c/Slicot_f_Import.def b/modules/cacsd/src/c/Slicot_f_Import.def new file mode 100755 index 000000000..0ca7b2f39 --- /dev/null +++ b/modules/cacsd/src/c/Slicot_f_Import.def @@ -0,0 +1,25 @@ +LIBRARY slicot_f.dll + + +EXPORTS +; --------------------------------------- +; slicot_f +; --------------------------------------- +ab01od_ +sb10dd_ +sb10fd_ +sb03od_ +sb03md_ +sb04rd_ +sb04nd_ +sb04py_ +sb04qd_ +sb04md_ +sb04pd_ +ab13md_ +ricdmf_ +ricdsl_ +riccms_ +riccsl_ +mb03od_ +zb03od_ diff --git a/modules/cacsd/src/c/cacsd.rc b/modules/cacsd/src/c/cacsd.rc new file mode 100755 index 000000000..e67ec959c --- /dev/null +++ b/modules/cacsd/src/c/cacsd.rc @@ -0,0 +1,95 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "cacsd module" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "cacsd module" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "cacsd.dll" + VALUE "ProductName", "cacsd module" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/cacsd/src/c/cacsd.vcxproj b/modules/cacsd/src/c/cacsd.vcxproj new file mode 100755 index 000000000..746cc8671 --- /dev/null +++ b/modules/cacsd/src/c/cacsd.vcxproj @@ -0,0 +1,268 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectGuid>{D5DD1407-3926-4F6C-AD7B-3A6B2DE56049}</ProjectGuid> + <RootNamespace>cacsd</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <WholeProgramOptimization>false</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <WholeProgramOptimization>false</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</LinkIncremental> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>.;../../includes;../../../core/includes;../../../output_stream/includes;../../../dynamic_link/includes;../../../dynamic_link/src/c;../../../localization/includes;../../../core/src/c;../../../../libs/intl;../../../cacsd/includes;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;_DEBUG;_WINDOWS;_USRDLL;CACSD_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slicot_f.lib" 1>NUL 2>NUL</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;cacsd_f.lib;linpack_f.lib;slicot_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>.;../../includes;../../../core/includes;../../../output_stream/includes;../../../dynamic_link/includes;../../../dynamic_link/src/c;../../../localization/includes;../../../core/src/c;../../../../libs/intl;../../../cacsd/includes;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;_DEBUG;_WINDOWS;_USRDLL;CACSD_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slicot_f.lib" 1>NUL 2>NUL</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;cacsd_f.lib;linpack_f.lib;slicot_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <ClCompile> + <FavorSizeOrSpeed>Speed</FavorSizeOrSpeed> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>.;../../includes;../../../core/includes;../../../output_stream/includes;../../../dynamic_link/includes;../../../dynamic_link/src/c;../../../localization/includes;../../../core/src/c;../../../../libs/intl;../../../cacsd/includes;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;NDEBUG;_WINDOWS;_USRDLL;CACSD_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <StringPooling>true</StringPooling> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slicot_f.lib" 1>NUL 2>NUL</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;cacsd_f.lib;linpack_f.lib;slicot_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>false</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <FavorSizeOrSpeed>Speed</FavorSizeOrSpeed> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>.;../../includes;../../../core/includes;../../../output_stream/includes;../../../dynamic_link/includes;../../../dynamic_link/src/c;../../../localization/includes;../../../core/src/c;../../../../libs/intl;../../../cacsd/includes;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;NDEBUG;_WINDOWS;_USRDLL;CACSD_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <StringPooling>true</StringPooling> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slicot_f.lib" 1>NUL 2>NUL</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;cacsd_f.lib;linpack_f.lib;slicot_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>false</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="..\..\sci_gateway\c\sci_dhinf.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_hinf.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_linmeq.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_mucomp.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_ricc2.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_rrankqr.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_zrankqr.c" /> + <ClCompile Include="DllmainCacsd.c" /> + <ClCompile Include="..\..\sci_gateway\c\gw_cacsd0.c" /> + <ClCompile Include="..\..\sci_gateway\c\gw_cacsd1.c" /> + <ClCompile Include="..\..\sci_gateway\c\gw_cacsd2.c" /> + <ClCompile Include="..\..\sci_gateway\c\gw_cacsd3.c" /> + <ClCompile Include="..\..\sci_gateway\c\gw_slicot.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_arl2.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_contr.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_ereduc.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_freq.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_fstair.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_gschur.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_gspec.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_ldiv.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_ltitr.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_ppol.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_rankqr.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_residu.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_rtitr.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_tzer.c" /> + </ItemGroup> + <ItemGroup> + <ClInclude Include="..\..\includes\dynlib_cacsd.h" /> + <ClInclude Include="..\..\includes\gw_cacsd0.h" /> + <ClInclude Include="..\..\includes\gw_cacsd1.h" /> + <ClInclude Include="..\..\includes\gw_cacsd2.h" /> + <ClInclude Include="..\..\includes\gw_cacsd3.h" /> + <ClInclude Include="..\..\includes\gw_slicot.h" /> + <ClInclude Include="..\..\sci_gateway\c\sci_contr.h" /> + <ClInclude Include="..\..\sci_gateway\c\sci_rankqr.h" /> + </ItemGroup> + <ItemGroup> + <None Include="..\..\locales\cacsd.pot" /> + <None Include="cacsd_f_Import.def" /> + <None Include="core_import.def" /> + <None Include="Linpack_f_Import.def" /> + <None Include="Slicot_f_Import.def" /> + <None Include="..\..\cacsd.iss" /> + <None Include="..\..\sci_gateway\cacsd_gateway.xml" /> + <None Include="..\..\Makefile.am" /> + </ItemGroup> + <ItemGroup> + <ResourceCompile Include="cacsd.rc" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + <ProjectReference Include="..\..\..\api_scilab\api_scilab.vcxproj"> + <Project>{43c5bab1-1dca-4743-a183-77e0d42fe7d0}</Project> + </ProjectReference> + <ProjectReference Include="..\..\..\output_stream\src\c\output_stream.vcxproj"> + <Project>{a5911cd7-f8e8-440c-a23e-4843a0636f3a}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/cacsd/src/c/cacsd.vcxproj.filters b/modules/cacsd/src/c/cacsd.vcxproj.filters new file mode 100755 index 000000000..8958af155 --- /dev/null +++ b/modules/cacsd/src/c/cacsd.vcxproj.filters @@ -0,0 +1,159 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{05a3ceda-1826-4fb3-ab50-630a00ee1a68}</UniqueIdentifier> + <Extensions>cpp;c;cxx;rc;def;r;odl;idl;hpj;bat</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{b7936932-769d-4d0d-b69b-5e39047c919c}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl</Extensions> + </Filter> + <Filter Include="localization"> + <UniqueIdentifier>{6a022500-943e-4485-86e1-d8672f7e89c4}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies"> + <UniqueIdentifier>{94018c87-7d94-4e42-a7b8-b6348c41571a}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies\Imports"> + <UniqueIdentifier>{f670670a-2cbd-444b-9e86-265642ba8444}</UniqueIdentifier> + </Filter> + <Filter Include="Resource File"> + <UniqueIdentifier>{47a5f967-09fd-40ed-a6e2-aad42eb8f3a4}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="DllmainCacsd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\gw_cacsd0.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\gw_cacsd1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\gw_cacsd2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\gw_cacsd3.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\gw_slicot.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_arl2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_contr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_ereduc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_freq.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_fstair.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_gschur.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_gspec.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_ldiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_ltitr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_ppol.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_rankqr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_residu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_rtitr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_tzer.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_dhinf.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_hinf.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_linmeq.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_mucomp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_ricc2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_rrankqr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_zrankqr.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <ClInclude Include="..\..\includes\dynlib_cacsd.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\gw_cacsd0.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\gw_cacsd1.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\gw_cacsd2.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\gw_cacsd3.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\gw_slicot.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\sci_gateway\c\sci_contr.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\sci_gateway\c\sci_rankqr.h"> + <Filter>Header Files</Filter> + </ClInclude> + </ItemGroup> + <ItemGroup> + <None Include="cacsd_f_Import.def"> + <Filter>Libraries Dependencies\Imports</Filter> + </None> + <None Include="core_import.def"> + <Filter>Libraries Dependencies\Imports</Filter> + </None> + <None Include="Linpack_f_Import.def"> + <Filter>Libraries Dependencies\Imports</Filter> + </None> + <None Include="Slicot_f_Import.def"> + <Filter>Libraries Dependencies\Imports</Filter> + </None> + <None Include="..\..\cacsd.iss" /> + <None Include="..\..\sci_gateway\cacsd_gateway.xml" /> + <None Include="..\..\Makefile.am" /> + <None Include="..\..\locales\cacsd.pot"> + <Filter>localization</Filter> + </None> + </ItemGroup> + <ItemGroup> + <ResourceCompile Include="cacsd.rc"> + <Filter>Resource File</Filter> + </ResourceCompile> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/cacsd/src/c/core_Import.def b/modules/cacsd/src/c/core_Import.def new file mode 100755 index 000000000..8515ca9b0 --- /dev/null +++ b/modules/cacsd/src/c/core_Import.def @@ -0,0 +1,25 @@ + LIBRARY core.dll + + +EXPORTS +; +;core +; +ExceptionMessage +callFunctionFromGateway +com_ +sci_gateway +fortran_mex_gateway +intersci_ +errorinfo_ +createvar_ +stack_ +getrhsvar_ +checklhs_ +checkrhs_ +GetData +iIsComplex +gettype_ +vstk_ +MyHeapAlloc +MyHeapFree diff --git a/modules/cacsd/src/fortran/.deps/.dirstamp b/modules/cacsd/src/fortran/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/cacsd/src/fortran/.deps/.dirstamp diff --git a/modules/cacsd/src/fortran/.dirstamp b/modules/cacsd/src/fortran/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/cacsd/src/fortran/.dirstamp diff --git a/modules/cacsd/src/fortran/.libs/arl2.o b/modules/cacsd/src/fortran/.libs/arl2.o Binary files differnew file mode 100755 index 000000000..d978544c4 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/arl2.o diff --git a/modules/cacsd/src/fortran/.libs/arl2a.o b/modules/cacsd/src/fortran/.libs/arl2a.o Binary files differnew file mode 100755 index 000000000..80e5dffcb --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/arl2a.o diff --git a/modules/cacsd/src/fortran/.libs/calsca.o b/modules/cacsd/src/fortran/.libs/calsca.o Binary files differnew file mode 100755 index 000000000..a468d1dc3 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/calsca.o diff --git a/modules/cacsd/src/fortran/.libs/deg1l2.o b/modules/cacsd/src/fortran/.libs/deg1l2.o Binary files differnew file mode 100755 index 000000000..96063fb59 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/deg1l2.o diff --git a/modules/cacsd/src/fortran/.libs/degl2.o b/modules/cacsd/src/fortran/.libs/degl2.o Binary files differnew file mode 100755 index 000000000..0bdab25c9 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/degl2.o diff --git a/modules/cacsd/src/fortran/.libs/dfrmg.o b/modules/cacsd/src/fortran/.libs/dfrmg.o Binary files differnew file mode 100755 index 000000000..2a90cb9c7 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/dfrmg.o diff --git a/modules/cacsd/src/fortran/.libs/dhetr.o b/modules/cacsd/src/fortran/.libs/dhetr.o Binary files differnew file mode 100755 index 000000000..fd0caa004 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/dhetr.o diff --git a/modules/cacsd/src/fortran/.libs/domout.o b/modules/cacsd/src/fortran/.libs/domout.o Binary files differnew file mode 100755 index 000000000..11820ac62 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/domout.o diff --git a/modules/cacsd/src/fortran/.libs/dzdivq.o b/modules/cacsd/src/fortran/.libs/dzdivq.o Binary files differnew file mode 100755 index 000000000..61ef0d96c --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/dzdivq.o diff --git a/modules/cacsd/src/fortran/.libs/expan.o b/modules/cacsd/src/fortran/.libs/expan.o Binary files differnew file mode 100755 index 000000000..21a7b5fef --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/expan.o diff --git a/modules/cacsd/src/fortran/.libs/feq.o b/modules/cacsd/src/fortran/.libs/feq.o Binary files differnew file mode 100755 index 000000000..1a53da8f3 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/feq.o diff --git a/modules/cacsd/src/fortran/.libs/fout.o b/modules/cacsd/src/fortran/.libs/fout.o Binary files differnew file mode 100755 index 000000000..825341980 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/fout.o diff --git a/modules/cacsd/src/fortran/.libs/front.o b/modules/cacsd/src/fortran/.libs/front.o Binary files differnew file mode 100755 index 000000000..28fc43870 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/front.o diff --git a/modules/cacsd/src/fortran/.libs/giv.o b/modules/cacsd/src/fortran/.libs/giv.o Binary files differnew file mode 100755 index 000000000..6815b968f --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/giv.o diff --git a/modules/cacsd/src/fortran/.libs/hessl2.o b/modules/cacsd/src/fortran/.libs/hessl2.o Binary files differnew file mode 100755 index 000000000..88a09b477 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/hessl2.o diff --git a/modules/cacsd/src/fortran/.libs/jacl2.o b/modules/cacsd/src/fortran/.libs/jacl2.o Binary files differnew file mode 100755 index 000000000..4dd802d44 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/jacl2.o diff --git a/modules/cacsd/src/fortran/.libs/lq.o b/modules/cacsd/src/fortran/.libs/lq.o Binary files differnew file mode 100755 index 000000000..c8fdb1a7b --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/lq.o diff --git a/modules/cacsd/src/fortran/.libs/modul.o b/modules/cacsd/src/fortran/.libs/modul.o Binary files differnew file mode 100755 index 000000000..7f625bc10 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/modul.o diff --git a/modules/cacsd/src/fortran/.libs/mzdivq.o b/modules/cacsd/src/fortran/.libs/mzdivq.o Binary files differnew file mode 100755 index 000000000..230f81998 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/mzdivq.o diff --git a/modules/cacsd/src/fortran/.libs/onface.o b/modules/cacsd/src/fortran/.libs/onface.o Binary files differnew file mode 100755 index 000000000..b23fa54be --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/onface.o diff --git a/modules/cacsd/src/fortran/.libs/optml2.o b/modules/cacsd/src/fortran/.libs/optml2.o Binary files differnew file mode 100755 index 000000000..d511c4884 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/optml2.o diff --git a/modules/cacsd/src/fortran/.libs/outl2.o b/modules/cacsd/src/fortran/.libs/outl2.o Binary files differnew file mode 100755 index 000000000..a47844f78 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/outl2.o diff --git a/modules/cacsd/src/fortran/.libs/phi.o b/modules/cacsd/src/fortran/.libs/phi.o Binary files differnew file mode 100755 index 000000000..d7e2c54b0 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/phi.o diff --git a/modules/cacsd/src/fortran/.libs/qhesz.o b/modules/cacsd/src/fortran/.libs/qhesz.o Binary files differnew file mode 100755 index 000000000..8d113ddeb --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/qhesz.o diff --git a/modules/cacsd/src/fortran/.libs/qitz.o b/modules/cacsd/src/fortran/.libs/qitz.o Binary files differnew file mode 100755 index 000000000..1d9bf680a --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/qitz.o diff --git a/modules/cacsd/src/fortran/.libs/qvalz.o b/modules/cacsd/src/fortran/.libs/qvalz.o Binary files differnew file mode 100755 index 000000000..79ab24844 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/qvalz.o diff --git a/modules/cacsd/src/fortran/.libs/ricd.o b/modules/cacsd/src/fortran/.libs/ricd.o Binary files differnew file mode 100755 index 000000000..74c787d06 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/ricd.o diff --git a/modules/cacsd/src/fortran/.libs/rilac.o b/modules/cacsd/src/fortran/.libs/rilac.o Binary files differnew file mode 100755 index 000000000..f950b8472 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/rilac.o diff --git a/modules/cacsd/src/fortran/.libs/rootgp.o b/modules/cacsd/src/fortran/.libs/rootgp.o Binary files differnew file mode 100755 index 000000000..559432806 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/rootgp.o diff --git a/modules/cacsd/src/fortran/.libs/rtitr.o b/modules/cacsd/src/fortran/.libs/rtitr.o Binary files differnew file mode 100755 index 000000000..524a976bf --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/rtitr.o diff --git a/modules/cacsd/src/fortran/.libs/scapol.o b/modules/cacsd/src/fortran/.libs/scapol.o Binary files differnew file mode 100755 index 000000000..5e573805e --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/scapol.o diff --git a/modules/cacsd/src/fortran/.libs/shrslv.o b/modules/cacsd/src/fortran/.libs/shrslv.o Binary files differnew file mode 100755 index 000000000..242ab903f --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/shrslv.o diff --git a/modules/cacsd/src/fortran/.libs/sszer.o b/modules/cacsd/src/fortran/.libs/sszer.o Binary files differnew file mode 100755 index 000000000..b07b2232b --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/sszer.o diff --git a/modules/cacsd/src/fortran/.libs/storl2.o b/modules/cacsd/src/fortran/.libs/storl2.o Binary files differnew file mode 100755 index 000000000..226ca94b0 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/storl2.o diff --git a/modules/cacsd/src/fortran/.libs/tild.o b/modules/cacsd/src/fortran/.libs/tild.o Binary files differnew file mode 100755 index 000000000..edba9f141 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/tild.o diff --git a/modules/cacsd/src/fortran/.libs/watfac.o b/modules/cacsd/src/fortran/.libs/watfac.o Binary files differnew file mode 100755 index 000000000..185bf5cb4 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/watfac.o diff --git a/modules/cacsd/src/fortran/.libs/wdegre.o b/modules/cacsd/src/fortran/.libs/wdegre.o Binary files differnew file mode 100755 index 000000000..61beacbf6 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/wdegre.o diff --git a/modules/cacsd/src/fortran/.libs/wesidu.o b/modules/cacsd/src/fortran/.libs/wesidu.o Binary files differnew file mode 100755 index 000000000..645eb89c9 --- /dev/null +++ b/modules/cacsd/src/fortran/.libs/wesidu.o diff --git a/modules/cacsd/src/fortran/Core_f_Import.def b/modules/cacsd/src/fortran/Core_f_Import.def new file mode 100755 index 000000000..18de2c7c1 --- /dev/null +++ b/modules/cacsd/src/fortran/Core_f_Import.def @@ -0,0 +1,9 @@ +LIBRARY core_f.dll + + +EXPORTS +;core_f + +putfunnam_ +cvname_ +folhp_ diff --git a/modules/cacsd/src/fortran/Differential_equations_f_Import.def b/modules/cacsd/src/fortran/Differential_equations_f_Import.def new file mode 100755 index 000000000..fef8c2699 --- /dev/null +++ b/modules/cacsd/src/fortran/Differential_equations_f_Import.def @@ -0,0 +1,5 @@ +LIBRARY differential_equations_f.dll + + +EXPORTS +lsode_
\ No newline at end of file diff --git a/modules/cacsd/src/fortran/Elementary_functions_Import.def b/modules/cacsd/src/fortran/Elementary_functions_Import.def new file mode 100755 index 000000000..8bc1caa32 --- /dev/null +++ b/modules/cacsd/src/fortran/Elementary_functions_Import.def @@ -0,0 +1,6 @@ +LIBRARY elementary_functions.dll + + +EXPORTS +unsfdcopy_ +int2db_ diff --git a/modules/cacsd/src/fortran/Elementary_functions_f_Import.def b/modules/cacsd/src/fortran/Elementary_functions_f_Import.def new file mode 100755 index 000000000..9317aadf1 --- /dev/null +++ b/modules/cacsd/src/fortran/Elementary_functions_f_Import.def @@ -0,0 +1,14 @@ +LIBRARY elementary_functions_f.dll + + +EXPORTS + +wdiv_ +dset_ +dtild_ +dadd_ +dmmul_ +ddif_ +entier_ +orthes_ +ortran_
\ No newline at end of file diff --git a/modules/cacsd/src/fortran/Output_stream_Import.def b/modules/cacsd/src/fortran/Output_stream_Import.def new file mode 100755 index 000000000..c7303ae58 --- /dev/null +++ b/modules/cacsd/src/fortran/Output_stream_Import.def @@ -0,0 +1,9 @@ +LIBRARY output_stream.dll + + +EXPORTS + +error_ +msgs_ +basout_ + diff --git a/modules/cacsd/src/fortran/Output_stream_f_Import.def b/modules/cacsd/src/fortran/Output_stream_f_Import.def new file mode 100755 index 000000000..9518bb416 --- /dev/null +++ b/modules/cacsd/src/fortran/Output_stream_f_Import.def @@ -0,0 +1,7 @@ +LIBRARY output_stream_f.dll + + +EXPORTS +dmdspf_ + + diff --git a/modules/cacsd/src/fortran/Polynomials_f_Import.def b/modules/cacsd/src/fortran/Polynomials_f_Import.def new file mode 100755 index 000000000..64ae7f87a --- /dev/null +++ b/modules/cacsd/src/fortran/Polynomials_f_Import.def @@ -0,0 +1,15 @@ +LIBRARY polynomials_f.dll + + +EXPORTS +rpoly_ +dpodiv_ +dpmul1_ +mpdegr_ +wpodiv_ +dmp2pm_ +residu_ +horner_ +idegre_ + + diff --git a/modules/cacsd/src/fortran/Slatec_f_Import.def b/modules/cacsd/src/fortran/Slatec_f_Import.def new file mode 100755 index 000000000..ced41335d --- /dev/null +++ b/modules/cacsd/src/fortran/Slatec_f_Import.def @@ -0,0 +1,7 @@ +LIBRARY slatec_f.dll + + +EXPORTS +balanc_ + + diff --git a/modules/cacsd/src/fortran/Slicot_f_Import.def b/modules/cacsd/src/fortran/Slicot_f_Import.def new file mode 100755 index 000000000..0be34dd7f --- /dev/null +++ b/modules/cacsd/src/fortran/Slicot_f_Import.def @@ -0,0 +1,19 @@ +LIBRARY slicot_f.dll + + +EXPORTS +inva_ +zb03od_ +ib01ad_ +ib01bd_ +polmc_ +mb03od_ +ssxmc_ +fstair_ +ib01cd_ +ereduc_ + + + + + diff --git a/modules/cacsd/src/fortran/arl2.f b/modules/cacsd/src/fortran/arl2.f new file mode 100755 index 000000000..a96bcfef9 --- /dev/null +++ b/modules/cacsd/src/fortran/arl2.f @@ -0,0 +1,272 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - M Cardelli, L Baratchart INRIA sophia-Antipolis 1989, S Steer +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine arl2(f,nf,num,tq,dgmin,dgmax,errl2,w,iw,inf,ierr,ilog) +C!but +C Cette procedure a pour but de gerer l'execution dans +C le cas ou un unique polynome approximant est desire +C!liste d'appel +C subroutine arl2(f,nf,num,tq,dgmin,dgmax,errl2,w, +C $ inf,ierr,ilog) +C +C double precision tq(dgmax+1),f(nf),num(dgmax) +C double precision w(*) +C integer dgmin,dgmax,dginit,info,ierr,iw(*) +C +C Entree : +C dgmin. est le degre du polynome de depart quand il est +C fourni, (vaux 0 s'il ne l'est pas). +C dginit. est le premier degre pour lequel aura lieu la +C recherche. +C dgmax. est le degre desire du dernier approximant +C tq. est le tableau contenant le polynome qui peut etre +C fourni comme point de depart par l'utilisateur. +C +C Sortie : +C tq. contient la solution obtenu de degre dgmax. +C num. contient les coefficients du numerateur optimal +C errl2. contient l'erreur L2 pour l'optimum retourne +C ierr. contient l'information sur le deroulement du programme +C ierr=0 : ok +C ierr=3 : boucle indesirable sur 2 ordres +C ierr=4 : plantage lsode +C ierr=5 : plantage dans recherche de l'intersection avec une face +C +C tableau de travail +C w: dimension: 32+32*dgmax+7*ng+dgmax*ng+dgmax**2*(ng+2) +C iw : dimension 29+dgmax**2+4*dgmax +C!sous programme appeles +C optml2,feq,jacl2,outl2,lq,phi (arl2) +C dcopy,dnrm2,dscal,dpmul1 +C!organigramme +C arl2 +C optml2 +C outl2 +C feq +C domout +C onface +C rootgp +C feq +C outl2 +C outl2 +C phi +C lsode +C front +C watfac +C front +C lsode +C feq +C jacl2 +C hessl2 +C lq +C outl2 +C feq +C phi +C lq +C jacl2 +C phi +C lq +C calsca +C feq +C lq +C calsca +C lq +C! +c Copyright INRIA + integer dgmin,dgmax,dginit,info,ierr,iw(*) + double precision tq(dgmax+1),f(nf),num(dgmax),w(*),x +C + double precision errl2,xx(1) + double precision tps(2),tms(2),dnrm2,sqrt,phi,gnrm,phi0 + integer dg,dgback,dgr + external feq, jacl2 + common /sortie/ io,info,ll + common /no2f/ gnrm +C +c taille des tableaux de travail necessaires a lsode + lrw = dgmax**2 + 9*dgmax + 22 + liw = 20+dgmax + +C decoupage du tableau de travail w + ncoeff=nf + ng=nf-1 + ltq = 1 + ltg = ltq+dgmax+1 + lwode = ltg+ng+1 + ltr = lwode+5+5*dgmax+5*ng+dgmax*ng+dgmax**2*(ng+1) + lfree = ltr + 25+26*dgmax+ng+dgmax**2 + +c les lrw elements de w suivant w(ltr) ne doivent pas etre modifies +c d'un appel de optml2 a l'autre + lw=ltr+lrw +C +C decoupage du tableau de travail iw + liwode = 1 + liww = liwode+4+(dgmax+1)*(dgmax+2) + lifree = liww+20+dgmax + iw(liwode+1)=ng + iw(liwode+2)=dgmax + ll = 80 + info = inf + io = ilog +C +C test validite des arguments +C + if (dgmin .gt. 0) then + dginit = dgmin + call dcopy(dgmin+1,tq,1,w(ltq),1) + else + w(ltq) = 1.d0 + dginit = 1 + endif +C + dgr=dginit + ierr = 0 + ntest1 = -1 +C + ng = nf - 1 + call dcopy(nf,f,1,w(ltg),1) + gnrm = dnrm2(nf,f,1) + call dscal(nf,1.0d+0/gnrm,w(ltg),1) + gnrm = gnrm**2 +C + tps(1) = 1.0d+0 + tps(2) = 1.0d+0 + tms(1) = -1.0d+0 + tms(2) = 1.0d+0 +C +C ---- Boucle de calcul --------------------------------------------- +C + do 500 nnn = dginit,dgmax +C + ifaceo = 0 +C + if (nnn .eq. dginit) then + if (dgmin .gt. 0) then + dg = dginit + goto 230 + else + dg = dginit - 1 + endif + endif +C + 200 dg = dg + 1 +C +C -- Initialisation du nouveau point de depart -- +C (dans l'espace de dimension dg , Hyperespace superieur +C d'une dimension par rapport au precedent ). +C + if (ntest1 .eq. 1) then + call dpmul1(w(ltq),dg-1,tps,1,w(ltr)) + call dcopy(dg+1,w(ltr),1,w(ltq),1) + elseif (ntest1 .eq. -1) then + call dpmul1(w(ltq),dg-1,tms,1,w(ltr)) + call dcopy(dg+1,w(ltr),1,w(ltq),1) + endif +C +C ------------------------ +C + 230 dgback = dg +C + if (info .gt. 1) call outl2(20,dg,dgback,xx,xx,x,x) +C + nch = 1 + iw(liwode)=dg + call optml2(feq,jacl2,iw(liwode),w(ltq),nch,w(ltr),iw) + dg=iw(liwode) + if (info .gt. 1) then + call lq(dg,w(ltq),w(lw),w(ltg),ng) + x=sqrt(gnrm) + call dscal(dg,x,w(lw),1) + call outl2(nch,dg,dg,w(ltq),w(lw),x,x) + + phi0= abs(phi(w(ltq),dg,w(ltg),ng,w(lw))) + lqdot=lw + call feq(iw(liwode),t,w(ltq),w(lqdot)) + call outl2(17,dg,dg,w(ltq),w(lqdot),phi0,x) + endif + + if (nch .ge. 15) then + if(nch.eq.17) then + call dcopy(dg+1,w(ltq),1,tq,1) + dgr=dg + goto 231 + endif + ierr = 4 + nch - 15 + goto 510 + endif +C + if (nch .lt. 0) then + ifaceo = ifaceo + 1 + ntest1 = (-1) * ntest1 + if (dg .eq. 0) goto 200 + goto 230 + endif +C + if (info .gt. 1) call outl2(21,dg,dg,xx,xx,x,x) + nch = 2 + iw(liwode)=dg + call optml2(feq,jacl2,iw(liwode),w(ltq),nch,w(ltr),iw) + if (info .gt. 0) then + call lq(dg,w(ltq),w(lw),w(ltg),ng) + x=sqrt(gnrm) + call dscal(dg,x,w(lw),1) + call outl2(nch,dg,dg,w(ltq),w(lw),x,x) + + phi0= abs(phi(w(ltq),dg,w(ltg),ng,w(lw))) + lqdot=lw + call feq(iw(liwode),t,w(ltq),w(lqdot)) + call outl2(17,dg,dg,w(ltq),w(lqdot),phi0,x) + endif + if (nch .ge. 15) then + if(nch.eq.17) then + call dcopy(dg+1,w(ltq),1,tq,1) + dgr=dg + goto 231 + endif + ierr = 4 + nch - 15 + goto 510 + endif +C + if (nch .lt. 0) then + ifaceo = ifaceo + 1 + ntest1 = (-1) * ntest1 + if (dg .eq. 0) goto 200 + goto 230 + endif +C +C + 231 if (ifaceo .eq. 8) then + if (info .ge. 0) call outl2(22,dg,dg,xx,xx,x,x) + ierr = 3 + goto 510 + endif +C + if (dg .lt. nnn) goto 200 + call dcopy(dg+1,w(ltq),1,tq,1) + dgr=dg +C + 500 continue +C +C Fin de la recherche Optimale +C numerateur optimal + 510 gnrm = sqrt(gnrm) + call lq(dgr,tq,w(ltr),w(ltg),ng) + call dcopy(dgr,w(ltr),1,num,1) + call dscal(dgr,gnrm,num,1) +C Le gradient de la fonction critere y vaut :-tqdot +C call feq(dg,t,w(ltq),tqdot) +C valeur du critere + lw = ltg+ncoeff+1 + errl2 = sqrt(phi(tq,dgr,w(ltg),ng,w(lw))) * gnrm + dgmax=dgr +C + return + end + diff --git a/modules/cacsd/src/fortran/arl2.lo b/modules/cacsd/src/fortran/arl2.lo new file mode 100755 index 000000000..71b6e9a38 --- /dev/null +++ b/modules/cacsd/src/fortran/arl2.lo @@ -0,0 +1,12 @@ +# src/fortran/arl2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/arl2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/arl2a.f b/modules/cacsd/src/fortran/arl2a.f new file mode 100755 index 000000000..5a6387082 --- /dev/null +++ b/modules/cacsd/src/fortran/arl2a.f @@ -0,0 +1,136 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - M Cardelli L Baratchart INRIA Sophia-Antipolis 1989 +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine arl2a(f,nf,ta,mxsol,imina,nall,inf,ierr,ilog,w,iw) +C!but +C Cette procedure a pour but de rechercher le plus +C grand nombre d'approximants pour chaque degre en partant +C du degre 1 jusqu'a l'ordre nall. +C!liste d'appel +C subroutine arl2a(f,nf,ta,nta,nall,info,ierr,io) +C double precision ta(mxsol,0:nall),f(nf),w(*) +C integer iw(*) +C +C entrees +C f : vecteur des coefficients de Fourier +C nf : nombre de coefficients de Fourrier maxi 200 +C nall: degre des polynomes minimums que l'on veut atteindre. +C inf : impression de la progression de l'algorithme: +C 0 = rien +C 1 = resultats intermediaires et messages d'erreur +C 2 = suivi detaille +C ilog : etiquette logique du fichier ou sont ecrite ces informations +C +C sorties +C ta :tableau contenant les minimums locaux a l'ordre nall +C imina : nombre de minimums trouves +C ierr. contient l'information sur le deroulement du programme +C ierr=0 : ok +C ierr=1 : trop de coefficients de fourrier (maxi 200) +C ierr=2 : ordre d'approximation trop eleve +C ierr=3 : boucle indesirable sur 2 ordres +C ierr=4 : plantage lsode +C ierr=5 : plantage dans recherche de l'intersection avec une face +C ierr=7 : trop de solutions +C +C tableaux de travail +C w: 34+34*nall+7*ng+nall*ng+nall**2*(ng+2)+4*(nall+1)*mxsol +C iw :29+nall**2+4*nall+2*mxsol + implicit double precision (a-h,o-y) + dimension ta(mxsol,*), f(nf), w(*), iw(*), x(1) + integer dgmax +C + common /sortie/ io,info,ll + common /no2f/ gnrm + common /comall/ nall1 + +C decoupage du tableau de travail w + dgmax=nall + ncoeff=nf + ng=nf-1 + ldeg =1 + ltb = ldeg + 33+33*dgmax+7*ng+dgmax*ng+dgmax**2*(ng+2) + ltc = ltb + (nall+1)*mxsol + ltback = ltc + (nall+1)*mxsol + lter = ltback + (nall+1)*mxsol + ltq = ltback + (nall+1)*mxsol + lfree = ltq + nall + 1 +C +C decoupage du tableau de travail iw + ildeg = 1 + ilntb = ildeg +29+dgmax**2+4*dgmax + ilnter = ilntb + mxsol + ilfree = ilnter + mxsol +C initialisations + io = ilog + ll = 80 + info = inf + nall1 = nall +C +C test validite des arguments +C + ng = nf - 1 + gnrm = dnrm2(nf,f,1) + call dscal(nf,1.0d+0/gnrm,f,1) + gnrm = gnrm**2 +C +C + iback = 0 +C + call deg1l2(f,ng,imina,ta,mxsol,w(ldeg),iw(ildeg),ierr) + if (ierr .gt. 0) return + if (nall .eq. 1) goto 400 + neq = 1 +C + do 200 ideg = 2,nall + call degl2(f,ng,neq,imina,iminb,iminc,ta,w(ltb),w(ltc),iback, + & iw(ilntb),w(ltback),mxsol,w(ldeg),iw(ildeg),ierr) + if (ierr .gt. 0) return +C + if (imina .eq. 0) goto 201 +C + 200 continue +C + 201 if (info .gt. 1) call outl2(23,neq,iback,x,x,tt,tt) +C + if (iback .gt. 0) then + imina = 0 + neq = iw(ilntb) + inf = 1 + do 300 ideg = neq,nall-1 +C + do 250 j = inf,iback + ntbj = iw(ilntb+j-1) + if (ntbj .eq. neq) then + call dcopy(ntbj,w(ltback-1+j),mxsol,w(ltq),1) + w(ltq+ntbj) = 1.0d+0 +C + nch = 1 +C remplacement de tq par w(ltq) tq n'est pas defini + call storl2(neq,w(ltq),f,ng,imina,ta,iback,iw(ilnter), + & w(lter),nch,mxsol,w(ldeg),ierr) + else + inf = j + goto 260 + endif + 250 continue +C + 260 continue + call degl2(f,ng,neq,imina,iminb,iminc,ta,w(ltb),w(ltc),iback, + & iw(ilnter),w(lter),mxsol,w(ldeg),iw(ildeg),ierr) + if (ierr .gt. 0) return +C + 300 continue + endif +C + 400 continue +C + return + end + diff --git a/modules/cacsd/src/fortran/arl2a.lo b/modules/cacsd/src/fortran/arl2a.lo new file mode 100755 index 000000000..c139ab992 --- /dev/null +++ b/modules/cacsd/src/fortran/arl2a.lo @@ -0,0 +1,12 @@ +# src/fortran/arl2a.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/arl2a.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/cacsd_Import.def b/modules/cacsd/src/fortran/cacsd_Import.def new file mode 100755 index 000000000..ed60bfb36 --- /dev/null +++ b/modules/cacsd/src/fortran/cacsd_Import.def @@ -0,0 +1,11 @@ +LIBRARY cacsd.dll + + +EXPORTS +; import required by F2C +sortie_ +comall_ +temps_ +no2f_ +arl2c_ +;
\ No newline at end of file diff --git a/modules/cacsd/src/fortran/cacsd_f.rc b/modules/cacsd/src/fortran/cacsd_f.rc new file mode 100755 index 000000000..fc25f7647 --- /dev/null +++ b/modules/cacsd/src/fortran/cacsd_f.rc @@ -0,0 +1,95 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "elementary_functions_f module" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "elementary_functions_f module" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "elementary_functions_f.dll" + VALUE "ProductName", "elementary_functions_f module" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/cacsd/src/fortran/cacsd_f.vfproj b/modules/cacsd/src/fortran/cacsd_f.vfproj new file mode 100755 index 000000000..666d954bb --- /dev/null +++ b/modules/cacsd/src/fortran/cacsd_f.vfproj @@ -0,0 +1,199 @@ +<?xml version="1.0" encoding="UTF-8"?> +<VisualStudioProject ProjectType="typeDynamicLibrary" ProjectCreator="Intel Fortran" Keyword="Dll" Version="11.0" ProjectIdGuid="{0BB16C71-0FCD-4FB9-B7C0-F2601330C980}"> + <Platforms> + <Platform Name="Win32"/> + <Platform Name="x64"/></Platforms> + <Configurations> + <Configuration Name="Debug|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="cacsd_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../bin/blasplus.lib ../../../../bin/lapack.lib core.lib cacsd.lib elementary_functions.lib elementary_functions_f.lib slicot_f.lib polynomials_f.lib output_stream_f.lib output_stream.lib slatec_f.lib differential_equations_f.lib eispack_f.lib linpack_f.lib core_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)cacsd_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)cacsd.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)slicot_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)output_stream_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)output_stream_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)differential_equations_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)differential_equations_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="cacsd_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../bin/blasplus.lib ../../../../bin/lapack.lib core.lib cacsd.lib elementary_functions.lib elementary_functions_f.lib slicot_f.lib polynomials_f.lib output_stream_f.lib output_stream.lib slatec_f.lib differential_equations_f.lib eispack_f.lib linpack_f.lib core_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)cacsd_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)cacsd.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)slicot_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)output_stream_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)output_stream_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)differential_equations_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)differential_equations_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Debug|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="cacsd_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../bin/blasplus.lib ../../../../bin/lapack.lib core.lib cacsd.lib elementary_functions.lib elementary_functions_f.lib slicot_f.lib polynomials_f.lib output_stream_f.lib output_stream.lib slatec_f.lib differential_equations_f.lib eispack_f.lib linpack_f.lib core_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)cacsd_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)cacsd.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)slicot_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)output_stream_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)output_stream_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)differential_equations_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)differential_equations_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="cacsd_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../bin/blasplus.lib ../../../../bin/lapack.lib core.lib cacsd.lib elementary_functions.lib elementary_functions_f.lib slicot_f.lib polynomials_f.lib output_stream_f.lib output_stream.lib slatec_f.lib differential_equations_f.lib eispack_f.lib linpack_f.lib core_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)cacsd_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)cacsd.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)slicot_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)output_stream_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)output_stream_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)differential_equations_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)differential_equations_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration></Configurations> + <Files> + <Filter Name="Header Files" Filter="fi;fd"/> + <Filter Name="Library Dependencies"> + <File RelativePath=".\cacsd_Import.def"/> + <File RelativePath=".\Core_f_Import.def"/> + <File RelativePath=".\core_import.def"/> + <File RelativePath=".\Differential_equations_f_Import.def"/> + <File RelativePath=".\eispack_f_Import.def"/> + <File RelativePath=".\Elementary_functions_f_Import.def"/> + <File RelativePath=".\Elementary_functions_Import.def"/> + <File RelativePath=".\linpack_f_Import.def"/> + <File RelativePath=".\Output_stream_f_Import.def"/> + <File RelativePath=".\Output_stream_Import.def"/> + <File RelativePath=".\Polynomials_f_Import.def"/> + <File RelativePath=".\Slatec_f_Import.def"/> + <File RelativePath=".\Slicot_f_Import.def"/></Filter> + <Filter Name="Resource Files" Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"> + <File RelativePath=".\cacsd_f.rc"/></Filter> + <Filter Name="Source Files" Filter="f90;for;f;fpp;ftn;def;odl;idl"> + <File RelativePath=".\arl2.f"/> + <File RelativePath=".\arl2a.f"/> + <File RelativePath=".\calsca.f"/> + <File RelativePath=".\deg1l2.f"/> + <File RelativePath=".\degl2.f"/> + <File RelativePath=".\dfrmg.f"/> + <File RelativePath=".\dhetr.f"/> + <File RelativePath=".\domout.f"/> + <File RelativePath=".\dzdivq.f"/> + <File RelativePath=".\expan.f"/> + <File RelativePath=".\feq.f"/> + <File RelativePath=".\fout.f"/> + <File RelativePath=".\front.f"/> + <File RelativePath=".\giv.f"/> + <File RelativePath=".\hessl2.f"/> + <File RelativePath=".\jacl2.f"/> + <File RelativePath=".\lq.f"/> + <File RelativePath=".\modul.f"/> + <File RelativePath=".\mzdivq.f"/> + <File RelativePath=".\onface.f"/> + <File RelativePath=".\optml2.f"/> + <File RelativePath=".\outl2.f"/> + <File RelativePath=".\phi.f"/> + <File RelativePath=".\qhesz.f"/> + <File RelativePath=".\qitz.f"/> + <File RelativePath=".\qvalz.f"/> + <File RelativePath=".\ricd.f"/> + <File RelativePath=".\rilac.f"/> + <File RelativePath=".\rootgp.f"/> + <File RelativePath=".\rtitr.f"/> + <File RelativePath=".\scapol.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_arl2.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_ereduc.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_findbd.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_freq.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_fstair.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_gschur.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_gspec.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_ldiv.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_ltitr.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_lyap.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_ppol.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_residu.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_rtitr.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_sident.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_sorder.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_sylv.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_tzer.f"/> + <File RelativePath=".\shrslv.f"/> + <File RelativePath=".\sszer.f"/> + <File RelativePath=".\storl2.f"/> + <File RelativePath=".\tild.f"/> + <File RelativePath=".\watfac.f"/> + <File RelativePath=".\wdegre.f"/> + <File RelativePath=".\wesidu.f"/></Filter> + <File RelativePath="..\..\sci_gateway\cacsd_gateway.xml"/> + <File RelativePath="..\..\Makefile.am"/></Files> + <Globals/></VisualStudioProject> diff --git a/modules/cacsd/src/fortran/cacsd_f2c.vcxproj b/modules/cacsd/src/fortran/cacsd_f2c.vcxproj new file mode 100755 index 000000000..16f1ac0d0 --- /dev/null +++ b/modules/cacsd/src/fortran/cacsd_f2c.vcxproj @@ -0,0 +1,435 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectName>cacsd_f</ProjectName> + <ProjectGuid>{0BB16C71-0FCD-4FB9-B7C0-F2601330C980}</ProjectGuid> + <RootNamespace>cacsd_f2c</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + <Import Project="..\..\..\..\Visual-Studio-settings\f2c.props" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</LinkIncremental> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slicot_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)differential_equations_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)differential_equations_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;CACSD_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib;core.lib;cacsd.lib;elementary_functions.lib;elementary_functions_f.lib;slicot_f.lib;polynomials_f.lib;output_stream_f.lib;output_stream.lib;slatec_f.lib;differential_equations_f.lib;eispack_f.lib;linpack_f.lib;core_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>cacsd_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slicot_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)differential_equations_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)differential_equations_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;CACSD_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib;core.lib;cacsd.lib;elementary_functions.lib;elementary_functions_f.lib;slicot_f.lib;polynomials_f.lib;output_stream_f.lib;output_stream.lib;slatec_f.lib;differential_equations_f.lib;eispack_f.lib;linpack_f.lib;core_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>cacsd_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slicot_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)differential_equations_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)differential_equations_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;CACSD_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib;core.lib;cacsd.lib;elementary_functions.lib;elementary_functions_f.lib;slicot_f.lib;polynomials_f.lib;output_stream_f.lib;output_stream.lib;slatec_f.lib;differential_equations_f.lib;eispack_f.lib;linpack_f.lib;core_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>cacsd_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Slicot_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slicot_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)differential_equations_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)differential_equations_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;CACSD_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib;core.lib;cacsd.lib;elementary_functions.lib;elementary_functions_f.lib;slicot_f.lib;polynomials_f.lib;output_stream_f.lib;output_stream.lib;slatec_f.lib;differential_equations_f.lib;eispack_f.lib;linpack_f.lib;core_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>cacsd_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="arl2.c" /> + <ClCompile Include="arl2a.c" /> + <ClCompile Include="calsca.c" /> + <ClCompile Include="deg1l2.c" /> + <ClCompile Include="degl2.c" /> + <ClCompile Include="dfrmg.c" /> + <ClCompile Include="dhetr.c" /> + <ClCompile Include="domout.c" /> + <ClCompile Include="dzdivq.c" /> + <ClCompile Include="expan.c" /> + <ClCompile Include="feq.c" /> + <ClCompile Include="fout.c" /> + <ClCompile Include="front.c" /> + <ClCompile Include="giv.c" /> + <ClCompile Include="hessl2.c" /> + <ClCompile Include="jacl2.c" /> + <ClCompile Include="lq.c" /> + <ClCompile Include="modul.c" /> + <ClCompile Include="mzdivq.c" /> + <ClCompile Include="onface.c" /> + <ClCompile Include="optml2.c" /> + <ClCompile Include="outl2.c" /> + <ClCompile Include="phi.c" /> + <ClCompile Include="qhesz.c" /> + <ClCompile Include="qitz.c" /> + <ClCompile Include="qvalz.c" /> + <ClCompile Include="ricd.c" /> + <ClCompile Include="rilac.c" /> + <ClCompile Include="rootgp.c" /> + <ClCompile Include="rtitr.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_arl2.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ereduc.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_findbd.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_freq.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_fstair.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_gschur.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_gspec.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ldiv.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ltitr.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_lyap.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ppol.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_residu.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_rtitr.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sident.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sorder.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sylv.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_tzer.c" /> + <ClCompile Include="scapol.c" /> + <ClCompile Include="shrslv.c" /> + <ClCompile Include="sszer.c" /> + <ClCompile Include="storl2.c" /> + <ClCompile Include="tild.c" /> + <ClCompile Include="watfac.c" /> + <ClCompile Include="wdegre.c" /> + <ClCompile Include="wesidu.c" /> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="arl2.f" /> + <f2c_rule Include="arl2a.f" /> + <f2c_rule Include="calsca.f" /> + <f2c_rule Include="deg1l2.f" /> + <f2c_rule Include="degl2.f" /> + <f2c_rule Include="dfrmg.f" /> + <f2c_rule Include="dhetr.f" /> + <f2c_rule Include="domout.f" /> + <f2c_rule Include="dzdivq.f" /> + <f2c_rule Include="expan.f" /> + <f2c_rule Include="feq.f" /> + <f2c_rule Include="fout.f" /> + <f2c_rule Include="front.f" /> + <f2c_rule Include="giv.f" /> + <f2c_rule Include="hessl2.f" /> + <f2c_rule Include="jacl2.f" /> + <f2c_rule Include="lq.f" /> + <f2c_rule Include="modul.f" /> + <f2c_rule Include="mzdivq.f" /> + <f2c_rule Include="onface.f" /> + <f2c_rule Include="optml2.f" /> + <f2c_rule Include="outl2.f" /> + <f2c_rule Include="phi.f" /> + <f2c_rule Include="qhesz.f" /> + <f2c_rule Include="qitz.f" /> + <f2c_rule Include="qvalz.f" /> + <f2c_rule Include="ricd.f" /> + <f2c_rule Include="rilac.f" /> + <f2c_rule Include="rootgp.f" /> + <f2c_rule Include="rtitr.f" /> + <f2c_rule Include="scapol.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_arl2.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ereduc.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_findbd.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_freq.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_fstair.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_gschur.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_gspec.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ldiv.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ltitr.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_lyap.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ppol.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_residu.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_rtitr.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sident.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sorder.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sylv.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_tzer.f" /> + <f2c_rule Include="shrslv.f" /> + <f2c_rule Include="sszer.f" /> + <f2c_rule Include="storl2.f" /> + <f2c_rule Include="tild.f" /> + <f2c_rule Include="watfac.f" /> + <f2c_rule Include="wdegre.f" /> + <f2c_rule Include="wesidu.f" /> + </ItemGroup> + <ItemGroup> + <None Include="cacsd_Import.def" /> + <None Include="Core_f_Import.def" /> + <None Include="Differential_equations_f_Import.def" /> + <None Include="eispack_f_Import.def" /> + <None Include="Elementary_functions_f_Import.def" /> + <None Include="Elementary_functions_Import.def" /> + <None Include="core_import.def" /> + <None Include="linpack_f_Import.def" /> + <None Include="Output_stream_f_Import.def" /> + <None Include="Output_stream_Import.def" /> + <None Include="Polynomials_f_Import.def" /> + <None Include="Slatec_f_Import.def" /> + <None Include="Slicot_f_Import.def" /> + <None Include="..\..\sci_gateway\cacsd_gateway.xml" /> + <None Include="..\..\Makefile.am" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + <Import Project="..\..\..\..\Visual-Studio-settings\f2c.targets" /> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/cacsd/src/fortran/cacsd_f2c.vcxproj.filters b/modules/cacsd/src/fortran/cacsd_f2c.vcxproj.filters new file mode 100755 index 000000000..d8ea61d2e --- /dev/null +++ b/modules/cacsd/src/fortran/cacsd_f2c.vcxproj.filters @@ -0,0 +1,400 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{4FC737F1-C7A5-4376-A066-2A32D752A2FF}</UniqueIdentifier> + <Extensions>cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{93995380-89BD-4b04-88EB-625FBE52EBFB}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl;inc;xsd</Extensions> + </Filter> + <Filter Include="Resource Files"> + <UniqueIdentifier>{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}</UniqueIdentifier> + <Extensions>rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx;tiff;tif;png;wav</Extensions> + </Filter> + <Filter Include="Fortran files"> + <UniqueIdentifier>{df0479ca-8336-4380-8f1d-3787565b3b1b}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies"> + <UniqueIdentifier>{4068acc9-9358-4ad3-8c7f-bae7173e2169}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="arl2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="arl2a.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="calsca.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="deg1l2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="degl2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dfrmg.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dhetr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="domout.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dzdivq.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="expan.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="feq.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fout.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="front.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="giv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="hessl2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="jacl2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="lq.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="modul.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="mzdivq.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="onface.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="optml2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="outl2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="phi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qhesz.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qitz.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qvalz.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ricd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rilac.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rootgp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rtitr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_arl2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ereduc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_findbd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_freq.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_fstair.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_gschur.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_gspec.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ldiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ltitr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_lyap.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ppol.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_residu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_rtitr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sident.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sorder.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sylv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_tzer.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="shrslv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="sszer.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="storl2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="tild.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="watfac.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wdegre.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wesidu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="scapol.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="arl2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="arl2a.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="calsca.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="deg1l2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="degl2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dfrmg.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dhetr.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="domout.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dzdivq.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="expan.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="feq.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fout.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="front.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="giv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="hessl2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="jacl2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="lq.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="modul.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="mzdivq.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="onface.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="optml2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="outl2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="phi.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="qhesz.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="qitz.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="qvalz.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ricd.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="rilac.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="rootgp.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="rtitr.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="scapol.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_arl2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ereduc.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_findbd.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_freq.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_fstair.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_gschur.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_gspec.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ldiv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ltitr.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_lyap.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ppol.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_residu.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_rtitr.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sident.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sorder.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sylv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_tzer.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="shrslv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="sszer.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="storl2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="tild.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="watfac.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wdegre.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wesidu.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + </ItemGroup> + <ItemGroup> + <None Include="cacsd_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Differential_equations_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Elementary_functions_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Elementary_functions_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="core_import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Output_stream_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Output_stream_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Polynomials_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Slatec_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Slicot_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="..\..\sci_gateway\cacsd_gateway.xml" /> + <None Include="..\..\Makefile.am" /> + <None Include="eispack_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="linpack_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Core_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/cacsd/src/fortran/calsca.f b/modules/cacsd/src/fortran/calsca.f new file mode 100755 index 000000000..571d60b25 --- /dev/null +++ b/modules/cacsd/src/fortran/calsca.f @@ -0,0 +1,45 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine calsca(ns,ts,tr,y0,tg,ng) +c!but +c Calcule le produit scalaire entre une fonction de Hardi donnee +c par ses coefficients de fourrier et une fonction rationnelle r/s +c!liste d'appel +c subroutine calsca(ns,ts,tr,y0) +c Entrees : +c ng. est le plus grand indice (compte negativement) des +c coefficients de fourrier de la fonction de Hardi u +c tg. vecteur des coefficients de fourrier +c ns. est le degre du denominateur (polynome monique) +c ts. est le tableau des coefficients du denominateur +c tr. est le tableau des coefficients du numerateur dont +c le degre est inferieur a ns +c +c sortie : y0. contient la valeur du produit scalaire recherche. +c! + implicit double precision (a-h,o-z) + dimension ts(0:ns),tr(0:ns),x(0:40) + dimension tg(0:ng) +c + nu=ng+1 + do 20 i=0,ns-1 + x(i)=0.0d+0 + 20 continue + aux= x(ns-1) + do 30 k=nu,1,-1 + do 29 i=ns-1,1,-1 + x(i)= x(i-1) - ts(i)*aux + tr(i)*tg(k-1) + 29 continue + x(0)= -ts(0)*aux + tr(0)*tg(k-1) + aux=x(ns-1) + 30 continue + y0= x(ns-1) + return + end diff --git a/modules/cacsd/src/fortran/calsca.lo b/modules/cacsd/src/fortran/calsca.lo new file mode 100755 index 000000000..53a6eebb2 --- /dev/null +++ b/modules/cacsd/src/fortran/calsca.lo @@ -0,0 +1,12 @@ +# src/fortran/calsca.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/calsca.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/core_Import.def b/modules/cacsd/src/fortran/core_Import.def new file mode 100755 index 000000000..773347d7a --- /dev/null +++ b/modules/cacsd/src/fortran/core_Import.def @@ -0,0 +1,32 @@ + LIBRARY core.dll + + +EXPORTS +; +;core +; +recu_ +com_ +stack_ +vstk_ +iop_ +errgst_ +cha1_ +adre_ +intersci_ +mexerrmsgtxt_ +mxgetm_ +mxisnumeric_ +mxiscomplex_ +mxgetpr_ +mxgetn_ +mxcopyptrtoreal8_ +createvar_ +mxcreatefull_ +mxcopyreal8toptr_ +mexprintf_ +checklhs_ +checkrhs_ +getrhsvar_ +maxvol_ +errorinfo_ diff --git a/modules/cacsd/src/fortran/deg1l2.f b/modules/cacsd/src/fortran/deg1l2.f new file mode 100755 index 000000000..9890014f3 --- /dev/null +++ b/modules/cacsd/src/fortran/deg1l2.f @@ -0,0 +1,159 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine deg1l2(tg,ng,imin,ta,mxsol,w,iw,ierr) +C!but +C Determiner la totalite des polynome de degre 1. +C!liste d'appel +C sorties : +C -imin. est le nombre de minimums obtenus. +C -ta. est le tableau dans lequel sont conserves les +C minimums. +C tableaux de travail (dgmax=1) +C - w :32+32*dgmax+7*ng+dgmax*ng+dgmax**2*(ng+2)+2*mxsol +C -iw : 29+dgmax**2+4*dgmax+ mxsol +C!remarque +C on notera que le neq ieme coeff de chaque colonne +C devant contenir le coeff du plus au degre qui est +C toujours 1. contient en fait la valeur du critere +C pour ce polynome. +C! + implicit double precision (a-h,o-y) + dimension ta(mxsol,*),tg(ng+1) + external feq, feqn, jacl2, jacl2n +C + double precision x,phi0,phi,gnrm + dimension w(*), iw(*), xx(1) + integer dgmax + common /sortie/ io,info,ll + common /no2f/ gnrm +C +C + dgmax=1 + + ltq=1 + lwopt=ltq+6+6*dgmax+6*ng+dgmax*ng+dgmax**2*(ng+1) + ltback=lwopt+25+26*dgmax+ng+dgmax**2 + lfree = ltback + 2*mxsol +c +c les lrw elements de w suivant w(lwopt) ne doivent pas etre modifies +c d'un appel de optml2 a l'autre + lrw = dgmax**2 + 9*dgmax + 22 + lw=lwopt+lrw +c + + lneq=1 + liwopt=lneq+3+(dgmax+1)*(dgmax+2) + lntb =liwopt + 20+dgmax + lifree=lntb+mxsol +C + + minmax = -1 + neq = 1 + neqbac = 1 + iback=0 +c + iw(lneq)=neq + iw(lneq+1)=ng + iw(lneq+2)=dgmax +c + w(ltq)=0.99990d+0 + w(ltq+1)=1.0d+0 + ltg=ltq+2 + call dcopy(ng+1,tg,1,w(ltg),1) +C + if (info .gt. 0) call outl2(51,neq,neq,xx,xx,x,x) + do 120 icomp = 1,50 + if (minmax .eq. -1) then + nch = 1 + call optml2(feq,jacl2,iw(lneq),w(ltq),nch,w(lwopt), + $ iw(liwopt)) + if (info .gt. 1) then + call lq(neq,w(ltq),w(lw),w(ltg),ng) + x=sqrt(gnrm) + call dscal(neq,x,w(lw),1) + call outl2(nch,neq,neqbac,w(ltq),w(lw),x,x) + + phi0= abs(phi(w(ltq),neq,w(ltg),ng,w(lw))) + lqdot=lw + call feq(iw(lneq),t,w(ltq),w(lqdot)) + call outl2(17,neq,neq,w(ltq),w(lqdot),phi0,x) + endif + + nch = 2 + call optml2(feq,jacl2,iw(lneq),w(ltq),nch,w(lwopt), + $ iw(liwopt)) + if (info .gt. 0) then + call lq(neq,w(ltq),w(lw),w(ltg),ng) + x=sqrt(gnrm) + call dscal(neq,x,w(lw),1) + call outl2(nch,neq,neqbac,w(ltq),w(lw),x,x) + + phi0= abs(phi(w(ltq),neq,w(ltg),ng,w(lw))) + lqdot=lw + call feq(iw(lneq),t,w(ltq),w(lqdot)) + call outl2(17,neq,neq,w(ltq),w(lqdot),phi0,x) + endif + + minmax = 1 + else + nch = 1 + call optml2(feqn,jacl2n,iw(lneq),w(ltq),nch,w(lwopt), + $ iw(liwopt)) + if (info .gt. 1) then + call lq(neq,w(ltq),w(lw),w(ltg),ng) + x=sqrt(gnrm) + call dscal(neq,x,w(lw),1) + call outl2(nch,neq,neqbac,w(ltq),w(lw),x,x) + + phi0= abs(phi(w(ltq),neq,w(ltg),ng,w(lw))) + lqdot=lw + call feqn(iw(lneq),t,w(ltq),w(lqdot)) + call outl2(17,neq,neq,w(ltq),w(lqdot),phi0,x) + endif + nch = 2 + call optml2(feqn,jacl2n,iw(lneq),w(ltq),nch,w(lwopt), + $ iw(liwopt)) + if (info .gt. 0) then + call lq(neq,w(ltq),w(lw),w(ltg),ng) + x=sqrt(gnrm) + call dscal(neq,x,w(lw),1) + call outl2(nch,neq,neqbac,w(ltq),w(lw),x,x) + + phi0= abs(phi(w(ltq),neq,w(ltg),ng,w(lw))) + lqdot=lw + call feqn(iw(lneq),t,w(ltq),w(lqdot)) + call outl2(17,neq,neq,w(ltq),w(lqdot),phi0,x) + endif + + minmax = -1 + endif + if (abs(w(ltq)) .gt. 1.0d+0) goto 140 + if (minmax .eq. 1) then + if (icomp .eq. 1) then + imin = 1 + ta(imin,1) = w(ltq) + ta(imin,2) = phi(w(ltq),neq,tg,ng,w(lwopt)) + else + call storl2(neq,w(ltq),w(ltg),ng,imin,ta,iback,iw(lntb), + & w(ltback),nch,mxsol,w(lwopt),ierr) + if (ierr .gt. 0) return + endif + endif + w(ltq) = w(ltq) - 0.000010d+0 + 120 continue +C + 140 if (info .gt. 0) then + x = real(mxsol) + call outl2(52,neq,imin,ta,xx,x,x) + endif +C + return + end + diff --git a/modules/cacsd/src/fortran/deg1l2.lo b/modules/cacsd/src/fortran/deg1l2.lo new file mode 100755 index 000000000..67ec25e56 --- /dev/null +++ b/modules/cacsd/src/fortran/deg1l2.lo @@ -0,0 +1,12 @@ +# src/fortran/deg1l2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/deg1l2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/degl2.f b/modules/cacsd/src/fortran/degl2.f new file mode 100755 index 000000000..e96ac3573 --- /dev/null +++ b/modules/cacsd/src/fortran/degl2.f @@ -0,0 +1,213 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine degl2(tg,ng,neq,imina,iminb,iminc,ta,tb,tc,iback, + & ntback,tback,mxsol,w,iw,ierr) +C!but +C Cette procedure a pour objectif de determiner le plus grand +C nombre de minimums de degre "neq". +C!liste d'appel +C subroutine degre (neq,imina,iminb,iminc,ta,tb,tc, +C & iback,ntback,tback) +C +C Entree : +C -neq. est le degre des polynomes parmi lesquels ont +C recherche les minimums. +C -imina. est le nombre de minimums de degre "neq-1" +C contenus dans ta. +C -iminb. est le nombre de minimums de degre "neq-2" +C contenus dans tb. +C -iminc. est le nombre de minimums de degre "neq-3" +C contenus dans tc. +C -ta. est le tableau contenant donc les minimums de degre +C "neq-1" +C -tb. est le tableau contenant donc les minimums de degre +C "neq-2" +C -tc. est le tableau contenant donc les minimums de degre +C "neq-3" +C -iback. est le nombre de minimums obtenus apres une +C intersection avec la frontiere +C -ntback est un tableau d'entier qui contient les degre +C de ces minimums +C -tback. est le tableau qui contient leurs coefficients, +C ou ils sont ordonnes degre par degre. +C +C Sortie : +C -imina. est le nombre de minimums de degre neq que l'on +C vient de determiner +C -iminb. est le nombre de minimums de degre "neq-1" +C -iminc. est le nombre de minimums de degre "neq-2" +C -ta. contient les mins de degre neq, -tb. ceux de degre +C neq-1 et tc ceux de degre neq-2 +C -iback,ntback,tback ont pu etre augmente des mins obtenus +C apres intersection eventuelle avec la frontiere. +C +C tableaux de travail +C w : 33+33*neq+7*ng+neq*ng+neq**2*(ng+2) +C iw :29+neq**2+4*neq +c + + +C! + implicit double precision (a-h,o-y) + dimension ta(mxsol,*), tb(mxsol,*), tc(mxsol,*),tg(ng+1), + & ntback(mxsol), tback(mxsol,*) + dimension w(*), iw(*), xx(1) +C + dimension tps(0:1), tms(0:1) + double precision x,phi0,phi,gnrm +C + external feq, jacl2 + common /comall/ nall1 + common /sortie/ io,info,ll + common /no2f/ gnrm +C + tps(0) = 1.0d+0 + tps(1) = 1.0d+0 + tms(0) = -1.0d+0 + tms(1) = 1.0d+0 +C +C +C -------- Reinitialisation des tableaux -------- +C + if (neq .eq. 1) goto 111 +C + do 110 j = 1,iminb + call dcopy(neq,tb(j,1),mxsol,tc(j,1),mxsol) + 110 continue + iminc = iminb +C + 111 do 120 j = 1,imina + call dcopy(neq,ta(j,1),mxsol,tb(j,1),mxsol) + 120 continue + iminb = imina + imina = 0 + neq = neq + 1 + neqbac = neq +c + lrw = neq**2 + 9*neq + 22 + liw = 20+neq +C decoupage du tableau de travail w + ltq = 1 + lwopt = ltq+6+6*neq+6*ng+neq*ng+neq**2*(ng+1) + ltr = lwopt +25+26*neq+ng+neq**2 + lfree=ltr+neq+1 +c +c les lrw elements de w suivant w(lwopt) ne doivent pas etre modifies +c d'un appel de optml2 a l'autre + lw=lwopt+lrw + + ltg=ltq+neq+1 + call dcopy(ng+1,tg,1,w(ltg),1) + +C decoupage du tableau de travail iw + lneq=1 + liwopt=lneq+3+(neq+1)*(neq+2) + lifree =liwopt + 20+neq +c + iw(lneq)=neq + iw(lneq+1)=ng + iw(lneq+2)=neq + + + if (info .gt. 0) call outl2(51,neq,neq,xx,xx,x,x) +C +C -------- Boucles de calculs -------- +C + do 190 k = 1,iminb +C + call dcopy(neq-1,tb(k,1),mxsol,w(ltr),1) + w(ltr+neq-1) = 1.0d+0 +C + do 180 imult = 1,2 +C + if (imult .eq. 1) then + call dpmul1(w(ltr),neq-1,tps,1,w(ltq)) + elseif (imult .eq. 2) then + call dpmul1(w(ltr),neq-1,tms,1,w(ltq)) + endif +C + 140 continue +C + nch = 1 + call optml2(feq,jacl2,iw(lneq),w(ltq),nch,w(lwopt),iw(liwopt)) + neq=iw(lneq) + if(info.gt.1) call outl2(nch,iw(lneq),neqbac,w(ltq),xx,x,x) + if (info .gt. 0) then + call lq(neq,w(ltq),w(lw),w(ltg),ng) + x=sqrt(gnrm) + call dscal(neq,x,w(lw),1) + call outl2(nch,neq,neqbac,w(ltq),w(lw),x,x) + + phi0= abs(phi(w(ltq),neq,w(ltg),ng,w(lw))) + lqdot=lw + call feq(iw(lneq),t,w(ltq),w(lqdot)) + call outl2(17,neq,neq,w(ltq),w(lqdot),phi0,x) + endif + if (nch.eq.15 .and. nall1.eq.0) then + ierr = 4 + return + endif +C + if (nch .eq. -1) goto 140 + if (nch .eq. -2) goto 140 +C + nch = 2 + call optml2(feq,jacl2,iw(lneq),w(ltq),nch,w(lwopt),iw(liwopt)) + neq=iw(lneq) + if (info .gt. 1) then + call lq(neq,w(ltq),w(lw),w(ltg),ng) + x=sqrt(gnrm) + call dscal(neq,x,w(lw),1) + call outl2(nch,neq,neqbac,w(ltq),w(lw),x,x) + + phi0= abs(phi(w(ltq),neq,w(ltg),ng,w(lw))) + lqdot=lw + call feq(iw(lneq),t,w(ltq),w(lqdot)) + call outl2(17,neq,neq,w(ltq),w(lqdot),phi0,x) + endif + + if (nch.eq.15 .and. nall1.eq.0) then + ierr = 4 + return + endif +C +C + if (nch .eq. -1) goto 140 + if (nch .eq. -2) goto 140 +C + if (nch .eq. 15) then + if (info .gt. 0) call outl2(50,neq,neq,xx,xx,x,x) + goto 170 + endif +C + nch = neq - neqbac + if (nch .eq. -2) then + call storl2(neq,w(ltq),w(ltg),ng,iminc,tc,iback,ntback, + & tback,nch,mxsol,w(lwopt),ierr) + elseif (nch .eq. -1) then + call storl2(neq,w(ltq),w(ltg),ng,iminb,tb,iback,ntback, + & tback,nch,mxsol,w(lwopt),ierr) + else + call storl2(neq,w(ltq),w(ltg),ng,imina,ta,iback,ntback, + & tback,nch,mxsol,w(lwopt),ierr) + endif +C + 170 neq = neqbac + iw(lneq)=neq +C + 180 continue + 190 continue + if (info .gt. 0) then + x = real(mxsol) + call outl2(53,neq,imina,ta,xx,x,x) + endif + return + end + diff --git a/modules/cacsd/src/fortran/degl2.lo b/modules/cacsd/src/fortran/degl2.lo new file mode 100755 index 000000000..ad9c12250 --- /dev/null +++ b/modules/cacsd/src/fortran/degl2.lo @@ -0,0 +1,12 @@ +# src/fortran/degl2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/degl2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/dfrmg.f b/modules/cacsd/src/fortran/dfrmg.f new file mode 100755 index 000000000..626934f05 --- /dev/null +++ b/modules/cacsd/src/fortran/dfrmg.f @@ -0,0 +1,182 @@ + subroutine dfrmg(job,na,nb,nc,l,m,n,a,b,c,freqr,freqi, + + gr,gi,rcond,w,ipvt) + integer na,nb,nc,l,m,n,ipvt(n) + double precision a(na,n),b(nb,m),c(nc,n),freqr,freqi + double precision w(*),gr(nc,m),gi(nc,m) + double precision rcond,ddot + integer job +c +c *** purpose: +c sfrmg takes real matrices a (n x n), b (n x m), and c (l x n) +c and forms the complex frequency response matrix +c g(freq) := c * (((freq * i) - a)-inverse) * b +c where i = (n x n) identity matrix and freq is a complex +c scalar parameter taking values along the imaginary axis for +c continuous-time systems and on the unit circle for discrete- +c time systems. +c +c on entry: +c job integer +c set = 0. for the first call of dfrmg whereupon +c it is set to 1 for all subsequent calls; +c na integer +c the leading or row dimension of the real array a +c (and the complex array h) as declared in the main +c calling program. +c +c nb integer +c the leading or row dimension of the real array b +c (and the complex array ainvb) as declared in the main +c calling program. +c +c nc integer +c the leading or row dimension of the real array c +c (and the complex array g) as declared in the main +c calling program. +c +c l integer +c the number of rows of c (the number of outputs). +c +c m integer +c the number of columns of b (the number of inputs). +c +c n integer +c the order of the matrix a (the number of states); +c also = number of columns of c = number of rows of b. +c +c a real(na,n) +c a real n x n matrix (the system matrix); not needed as +c input if job .eq. .false. +c +c b real(nb,m) +c a real n x m matrix (the input matrix); not needed as +c input if job .eq. 1 +c +c c real(nc,n) +c a real l x n matrix (the output matrix); not needed as +c input if job .eq. 1 +c +c freq complex +c a complex scalar (the frequency parameter). +c on return: +c +c g complex(nc,m) +c the frequency response matrix g(freq). +c +c a,b,c a is in upper hessenberg form while b and c have been +c arrays are not further modified. +c rcond real +c parameter of subroutine checo (checo may be consulted +c for details); normal return is then +c (1.0 + rcond) .gt. 1.0. +c +c w (2*(n*n)+2*n) tableau de travail +c +c ipvt(n) tableau de travail entier +c this version dated june 1982. +c alan j. laub, university of southern california. +c +c subroutines and functions called: +c +c balanc(eispack) ,checo,chefa,chesl,hqr(eispack),shetr +c +c internal variables: +c + integer i,igh,j,k,kk,kp,low + double precision t +c +c fortran functions called: +c +c + if(job.ne.0) goto 150 + call balanc (na,n,a,low,igh,w) +c +c adjust b and c matrices based on information in the vector +c w which describes the balancing of a and is defined in the +c subroutine balanc +c + do 40 k = 1,n + kk = n-k+1 + if (kk .ge. low .and. kk .le. igh) go to 40 + if (kk .lt. low) kk = low-kk + kp = int(w(kk)) + if (kp .eq. kk) go to 40 +c +c permute rows of b +c + do 20 j = 1,m + t = b(kk,j) + b(kk,j) = b(kp,j) + b(kp,j) = t + 20 continue +c +c permute columns of c +c + do 30 i = 1,l + t = c(i,kk) + c(i,kk) = c(i,kp) + c(i,kp) = t + 30 continue +c + 40 continue + if (igh .eq. low) go to 80 + do 70 k = low,igh + t = w(k) +c +c scale columns of permuted c +c + do 50 i = 1,l + c(i,k) = c(i,k)*t + 50 continue +c +c scale rows of permuted b +c + do 60 j = 1,m + b(k,j) = b(k,j)/t + 60 continue +c + 70 continue + 80 continue +c +c reduce a to hessenberg form by orthogonal similarities and +c accumulate the orthogonal transformations into b and c +c + call dhetr (na,nb,nc,l,m,n,low,igh,a,b,c,w) +c + job = 1 +c +c update h := (freq *i) - a with appropriate value of freq +c + 150 continue + nn=n*n + j1=1-n + call dset(2*nn,0.0d+0,w,1) + do 170 j=1,n + j1=j1+n + call dcopy(min(j+1,n),a(1,j),1,w(j1),1) + w(j1+j-1)=w(j1+j-1)-freqr + 170 continue + call dset(n,-freqi,w(1+nn),n+1) +c +c factor the complex hessenberg matrix and estimate its +c condition +c + izr=nn+nn+1 + izi=izr+n + call wgeco(w(1),w(nn+1),n,n,ipvt,rcond,w(izr),w(izi)) + t = 1.0d+0+rcond +c if (t .eq. 1.0d+0) goto 250 +c +c compute c*(h-inverse)*b +c + do 220 j = 1,m + call dcopy(n,b(1,j),1,w(izr),1) + call dset(n,0.0d+0,w(izi),1) + call wgesl(w(1),w(nn+1),n,n,ipvt,w(izr),w(izi),0) + do 240 i=1,l + gr(i,j)=-ddot(n,c(i,1),nc,w(izr),1) + gi(i,j)=-ddot(n,c(i,1),nc,w(izi),1) + 240 continue + 220 continue + + end diff --git a/modules/cacsd/src/fortran/dfrmg.lo b/modules/cacsd/src/fortran/dfrmg.lo new file mode 100755 index 000000000..1d7330d2e --- /dev/null +++ b/modules/cacsd/src/fortran/dfrmg.lo @@ -0,0 +1,12 @@ +# src/fortran/dfrmg.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dfrmg.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/dhetr.f b/modules/cacsd/src/fortran/dhetr.f new file mode 100755 index 000000000..1d256c4a9 --- /dev/null +++ b/modules/cacsd/src/fortran/dhetr.f @@ -0,0 +1,141 @@ + subroutine dhetr(na,nb,nc,l,m,n,low,igh,a,b,c,ort) + double precision a(na,n),b(nb,m),c(nc,n),ort(n) +c +c *** purpose +c +c given a real general matrix a, shetr reduces a submatrix +c of a in rows and columns low through igh to upper hessenberg +c form by orthogonal similarity transformations. these +c orthogonal transformations are further accumulated into rows +c low through igh of an n x m matrix b and columns low +c through igh of an l x n matrix c by premultiplication and +c postmultiplication, respectively. +c +c +c b double precision(nb,m) +c an n x m double precision matrix +c +c c double precision(nc,n) +c an l x n double precision matrix. +c +c on return: +c +c a an upper hessenberg matric similar to (via an +c orthogonal matrix consisting of a sequence of +c householder transformations) the original matrix a; +c further information concerning the orthogonal +c transformations used in the reduction is contained +c in the elements below the first subdiagonal; see +c orthes documentation for details. +c +c b the original b matrix premultiplied by the transpose +c of the orthogonal transformation used to reduce a. +c +c c the original c matrix postmultiplied by the orthogonal +c transformation used to reduce a. +c +c ort double precision(n) +c a work vector containing information about the +c orthogonal transformations; see orthes documentation +c for details. +c +c this version dated july 1980. +c alan j. laub, university of southern california. +c +c subroutines and functions called: +c +c none +c +c internal variables: +c + integer i,ii,j,jj,k,kp1,kpn,la + double precision f,g,h,scale +c +c fortran functions called: +c + la = igh-1 + kp1 = low+1 + if (la .lt. kp1) go to 170 + do 160 k = kp1,la + h = 0.0d+0 + ort(k) = 0.0d+0 + scale = 0.0d+0 +c +c scale column +c + do 10 i = k,igh + scale = scale+abs(a(i,k-1)) + 10 continue + if (scale .eq. 0.0d+0) go to 150 + kpn=k+igh + do 20 ii = k,igh + i = kpn-ii + ort(i) = a(i,k-1)/scale + h = h+ort(i)*ort(i) + 20 continue + g = -sign(sqrt(h),ort(k)) + h = h-ort(k) *g + ort(k) = ort(k)-g +c +c form (i-(u*transpose(u))/h) *a +c + do 50 j = k,n + f = 0.0d+0 + do 30 ii = k,igh + i = kpn-ii + f = f+ort(i)*a(i,j) + 30 continue + f = f/h + do 40 i = k,igh + a(i,j) = a(i,j)-f*ort(i) + 40 continue + 50 continue +c +c form (i-(u*transpose(u))/h) *b +c + do 80 j = 1,m + f = 0.0d+0 + do 60 ii = k,igh + i = kpn-ii + f = f+ort(i) *b(i,j) + 60 continue + f = f/h + do 70 i = k,igh + b(i,j) = b(i,j)-f*ort(i) + 70 continue + 80 continue +c +c form (i-(u*transpose(u))/h) *a*(i-(u*transpose(u))/h) +c + do 110 i = 1,igh + f = 0.0d+0 + do 90 jj = k,igh + j = kpn-jj + f = f+ort(j)*a(i,j) + 90 continue + f = f/h + do 100 j = k,igh + a(i,j) = a(i,j)-f*ort(j) + 100 continue + 110 continue +c +c form c*(i-(u*transpose(u))/h) +c + do 140 i = 1,l + f = 0.0d+0 + do 120 jj = k,igh + j = kpn-jj + f = f+ort(j)*c(i,j) + 120 continue + f = f/h + do 130 j = k,igh + c(i,j) = c(i,j)-f*ort(j) + 130 continue + 140 continue + ort(k) = scale*ort(k) + a(k,k-1) = scale*g + 150 continue + 160 continue + 170 continue + return + end diff --git a/modules/cacsd/src/fortran/dhetr.lo b/modules/cacsd/src/fortran/dhetr.lo new file mode 100755 index 000000000..62b8203d9 --- /dev/null +++ b/modules/cacsd/src/fortran/dhetr.lo @@ -0,0 +1,12 @@ +# src/fortran/dhetr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dhetr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/domout.f b/modules/cacsd/src/fortran/domout.f new file mode 100755 index 000000000..6dabb9a2d --- /dev/null +++ b/modules/cacsd/src/fortran/domout.f @@ -0,0 +1,186 @@ + subroutine domout(neq,q,qi,nbout,ti,touti,itol,rtol,atol,itask + +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + $ ,istate,iopt,w,lrw,iw,liw,jacl2,mf,job) +C!but +C Etant sortie du domaine d'integration au cours +C de l'execution de la routine Optm2, il s'agit ici de +C gerer ou d'effectuer l'ensemble des taches necessaires +C a l'obtention du point de la face par lequel la +C 'recherche' est passee. +C!liste d'appel +C subroutine domout(neq,q,qi,nbout,ti,touti,itol,rtol,atol,itask, +C * istate,iopt,w,lrw,iw,liw,jacl2,mf,job) +C +C double precision atol(neq(1)+1),rtol(neq(1)+1),q(neq(1)+1), +C * qi(neq(1)+1) +C double precision w(*),iw(*) +C +C Entree : +c - neq. tableau entier de taille 3+(nq+1)*(nq+2) +c neq(1)=nq est le degre effectif du polynome q +c neq(2)=ng est le nombre de coefficient de fourier +c neq(3)=dgmax degre maximum pour q (l'adresse des coeff de +c fourier dans tq est neq(3)+2 +c neq(4:(nq+1)*(nq+2)) tableau de travail entier +c - tq. tableau reel de taille au moins +c 7+dgmax+5*nq+6*ng+nq*ng+nq**2*(ng+1) +c tq(1:nq+1) est le tableau des coefficients du polynome q. +c tq(dgmax+2:dgmax+ng+2) est le tableau des coefficients +c de fourier +c tq(dgmax+ng+3:) est un tableau de travail de taille au moins +c 5+5*nq+5*ng+nq*ng+nq**2*(ng+1) +c +C - toutes les variables et tableaux de variables necessaires a +C l'execution de la routine Lsode +C - qi. est le dernier point obtenu de la trajectoire +C qui soit a l'interieur du domaine. +C - q(1:nq+1). est celui precedemment calcule, qui se situe a +C l'exterieur. +C +C Sortie : +C - q(1:nq+1). est cense etre le point correspondant a l'inter- +C section entre la face et la trajectoire. +C - job. est un parametre indiquant si le franchissement +C est verifie. +C si job=-1 pb de detection arret requis +C +C Tableaux de travail +C - w : 24+22*nq+ng+nq**2 +C - iw : 20+nq +C! + implicit double precision (a-h,o-z) + dimension atol(*), rtol(*), w(*), iw(*), q(*), + & qi(*), xx(1) + + integer neq(*) + external feq, jacl2 + common /sortie/ io,info,ll +C + nq=neq(1) + ng=neq(2) + nqmax=neq(3) +c + lq=1 + ltg=lq+nqmax+1 +c + lrw=nq**2 + 9*nq + 22 + liw=20+nq +c + + lrwork = 1 + lw = lrwork + nq**2 + 9*nq + 22 + lqex = lw+12*nq+ng+1 + free = lqex + nq + 1 + +C + tout = touti + nboute = 0 +C +C --- Etape d'approche de la frontiere ---------------------------- +C + kmax = int(log((tout-ti)/0.006250d+0)/log(2.0d+0)) + k0 = 1 + if (info .gt. 1) call outl2(40,nq,kmax,xx,xx,x,x) + 314 do 380 k = k0,kmax + tpas = (tout-ti) / 2.0d+0 + if (nbout .gt. 0) then + istate = 1 + call dcopy(nq+1,qi,1,q,1) + t = ti + tout = ti + tpas + else + call dcopy(nq+1,q,1,qi,1) + ti = t + tout = ti + tpas + endif + 340 if (info .gt. 1) call outl2(41,nq,nq,q,xx,t,tout) + tsave=t + call lsode(feq,neq,q,t,tout,itol,rtol,atol,itask,istate,iopt, + & w(lrwork),lrw,iw,liw,jacl2,mf) + if (info .gt. 1) call outl2(42,nq,nq,q,xx,t,tout) + if (istate.eq.-1 .and. t.ne.tout) then + if (info .gt. 1) call outl2(43,nq,nq,xx,xx,x,x) + if (t.le.tsave) then + job=-1 + return + endif + istate = 2 + goto 340 + endif + call front(nq,q,nbout,w(lw)) + if (info .gt. 1) call outl2(44,nq,nbout,xx,xx,x,x) + if (nbout .gt. 0) then + nboute = nbout + call dcopy(nq+1,q,1,w(lqex),1) + endif + if (istate .lt. 0) then + if (info .gt. 1) call outl2(45,nq,istate,xx,xx,x,x) + job = -1 + return + endif + if (k.eq.kmax .and. nboute.eq.0 .and. tout.ne.touti) then + tout = touti + goto 340 + endif + 380 continue +c + if (nboute .eq. 0) then + job = 0 + return + elseif (nboute .gt. 2) then + newrap = 1 + nqsav = nq + goto 390 + endif +C + call watfac(nq,w(lqex),nface,newrap,w(lw)) + if (newrap .eq. 1) goto 390 +C + nqsav = nq + call onface(nq,q,q(ltg),ng,nface,ierr,w(lw)) + if (ierr .ne. 0) then + job = -1 + return + endif + yi = phi(qi,nqsav,q(ltg),ng,w(lw)) + yf = phi(q,nq,q(ltg),ng,w(lw)) +C + eps390 = 1.0d-08 + if (yi .lt. (yf-eps390)) then + newrap = 1 + goto 390 + endif +C + if (info .gt. 1) call outl2(46,nq,nface,q,xx,yi,yf) +C + newrap = 0 +C + 390 if (newrap .eq. 1) then + nq = nqsav + k0 = kmax + kmax = kmax + 1 + nbout = 1 + if(ti + 2*tpas.le.ti) then + job=-1 + return + endif + tout = ti + 2*tpas + if (info .gt. 1) call outl2(47,nq,nq,xx,qi,x,x) + goto 314 + endif +C + neq(1)=nq + job = 1 + return +C + end + diff --git a/modules/cacsd/src/fortran/domout.lo b/modules/cacsd/src/fortran/domout.lo new file mode 100755 index 000000000..e88757713 --- /dev/null +++ b/modules/cacsd/src/fortran/domout.lo @@ -0,0 +1,12 @@ +# src/fortran/domout.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/domout.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/dzdivq.f b/modules/cacsd/src/fortran/dzdivq.f new file mode 100755 index 000000000..29030b52f --- /dev/null +++ b/modules/cacsd/src/fortran/dzdivq.f @@ -0,0 +1,60 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine dzdivq(ichoix,nv,tv,nq,tq) +c!but +c calcule ici les quotient et reste de la division +c par q d'un polynome p, a partir des quotient et reste +c de la division par q du produit de ce polynome par z. +c!liste d'appel +c subroutine dzdivq(ichoix,nv,tv,nq,tq) +c Entree : +c - ichoix. prend la valeur 1 si l'on ne desire que +c calculer le nouveau quotient (puisqu'il ne se calcule +c qu'a partir du precedent. 2 sinon. +c - nv. est le degre du quotient entrant tv. +c - tv. est le tableau contenant les coeff. du quotient. +c - tr. est le tableau contenant les coeff. du reste de +c degre nq-1. +c - nq. est le degre du polynome tq. +c - tq. est le tableau contenant les coeff. du pol. tq. +c +c sortie : +c - nv. est le degre du nouveau quotient. +c - tv. contient les coeff. du nouveau quotient. +c - tr. ceux du nouveau reste de degre toujours nq-1. +c +c -------------------------- + + implicit double precision (a-h,o-y) + dimension tv(0:*),tq(0:*) +c + vaux=tv(nq) +c +c -- Calcul du nouveau quotient --------- +c + do 20 i=nq,nq+nv-1 + tv(i)=tv(i+1) + 20 continue +c + tv(nq+nv)=0.0d+0 + nv =nv-1 +c + if (ichoix.eq.1) return +c +c -- calcul du nouveau reste ------------ +c + do 30 i=0,nq-2 + tv(i)= vaux*tq(i+1) +tv(i+1) + 30 continue +c + tv(nq-1)=vaux +c + return + end diff --git a/modules/cacsd/src/fortran/dzdivq.lo b/modules/cacsd/src/fortran/dzdivq.lo new file mode 100755 index 000000000..2496e0296 --- /dev/null +++ b/modules/cacsd/src/fortran/dzdivq.lo @@ -0,0 +1,12 @@ +# src/fortran/dzdivq.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dzdivq.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/eispack_f_Import.def b/modules/cacsd/src/fortran/eispack_f_Import.def new file mode 100755 index 000000000..a55c46e6b --- /dev/null +++ b/modules/cacsd/src/fortran/eispack_f_Import.def @@ -0,0 +1,6 @@ +LIBRARY eispack_f.dll + + +EXPORTS +balbak_ +hqror2_ diff --git a/modules/cacsd/src/fortran/expan.f b/modules/cacsd/src/fortran/expan.f new file mode 100755 index 000000000..51b5fe306 --- /dev/null +++ b/modules/cacsd/src/fortran/expan.f @@ -0,0 +1,47 @@ + +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - F Delebecque +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine expan(a,la,b,lb,c,nmax) +c! but +c calcul des nmax premiers coefficients de la longue division de +c b par a .On suppose a(1) non nul. +c!liste d'appel +c subroutine expan(a,la,b,lb,c,nmax) +c a vecteur de longueur la des coeffs par puissances croissantes +c b " " lb " " " +c c nmax des coeffs de a/b +c + dimension a(la),b(lb),c(nmax) + double precision a,b,c,s,a0 +c + m=la + n=lb + a0=a(1) + if(a0.eq.0.0d+0) return + k=1 + 2 continue + s=0.0d+0 + if(k.eq.1) goto 8 + j=1 + 5 continue + j=j+1 + if(j.gt.min(m,k)) goto 8 + s=s+a(j)*c(k-j+1) + goto 05 + 8 continue + if(k.le.n) then + c(k)=(b(k)-s)/a0 + else + c(k)=-s/a0 + endif + if(k.eq.nmax) return + k=k+1 + goto 2 + end diff --git a/modules/cacsd/src/fortran/expan.lo b/modules/cacsd/src/fortran/expan.lo new file mode 100755 index 000000000..6c5701375 --- /dev/null +++ b/modules/cacsd/src/fortran/expan.lo @@ -0,0 +1,12 @@ +# src/fortran/expan.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/expan.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/feq.f b/modules/cacsd/src/fortran/feq.f new file mode 100755 index 000000000..e7204007d --- /dev/null +++ b/modules/cacsd/src/fortran/feq.f @@ -0,0 +1,139 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine feq(neq,t,tq,tqdot) +c!but +c Etablir la valeur de l'oppose du gradient au point q +c!liste d'appel +c subroutine feq(neq,t,tq,tqdot) +c - neq. tableau entier de taille 3+(nq+1)*(nq+2) +c neq(1)=nq est le degre effectif du polynome tq (ou q). +c neq(2)=ng est le nombre de coefficient de fourier +c neq(3)=dgmax degre maximum pour q (l'adresse des coeff de fourier dans +c tq est neq(3)+2 +c - t . variable parametrique necessaire a l'execution de +c la routine lsoda . +c - tq. tableau reel de taille au moins +c 3+dgmax+nq+2*ng +c tq(1:nq+1) est le tableau des coefficients du polynome q. +c tq(dgmax+2:dgmax+ng+2) est le tableau des coefficients +c de fourier +c tq(dgmax+ng+3:) est un tableau de travail de taille au moins +c nq+ng+1 +c Sortie : +c - tqdot . tableau contenant les opposes des coordonnees du +c gradient de la fonction PHI au point q +c!Remarque +c la structure particuliere pour neq et tq est liee au fait que feq peut +c etre appele comme un external de lsode +c! + + implicit double precision (a-h,o-y) + dimension tq(*),tqdot(*) + dimension neq(*) +c + + nq=neq(1) + ng=neq(2) +c +c decoupage du tableau tq + itq=1 + itg=itq+neq(3)+1 + iw=itg+ng+1 + ifree=iw+1+nq+ng + + call feq1(nq,t,tq,tq(itg),ng,tqdot,tq(iw)) + return + end + subroutine feqn(neq,t,tq,tqdot) +c!but +c Etablir la valeur du gradient au point q +c!liste d'appel +c subroutine feqn(neq,t,tq,tqdot) +c - neq. tableau entier de taille 3+(nq+1)*(nq+2) +c neq(1)=nq est le degre effectif du polynome tq (ou q). +c neq(2)=ng est le nombre de coefficient de fourier +c neq(3)=dgmax degre maximum pour q (l'adresse des coeff de fourier dans +c tq est neq(3)+2 +c - t . variable parametrique necessaire a l'execution de +c la routine lsoda . +c - tq. tableau reel de taille au moins +c 3+dgmax+nq+2*ng +c tq(1:nq+1) est le tableau des coefficients du polynome q. +c tq(dgmax+2:dgmax+ng+2) est le tableau des coefficients +c de fourier +c tq(dgmax+ng+3:) est un tableau de travail de taille au moins +c nq+ng+1 +c Sortie : +c - tqdot . tableau contenant les opposes des coordonnees du +c gradient de la fonction PHI au point q +c!Remarque +c la structure particuliere pour neq et tq est liee au fait que feq peut +c etre appele comme un external de lsode +c! + implicit double precision (a-h,o-y) + dimension tq(*),tqdot(*) + dimension neq(*) +c + + nq=neq(1) + ng=neq(2) +c +c decoupage du tableau tq + itq=1 + itg=itq+neq(3)+1 + iw=itg+ng+1 + ifree=iw+1+nq+ng + + call feq1(nq,t,tq,tq(itg),ng,tqdot,tq(iw)) + do 10 i=1,nq + tqdot(i)=-tqdot(i) + 10 continue + return + end + + subroutine feq1(nq,t,tq,tg,ng,tqdot,tr) + implicit double precision (a-h,o-y) + dimension tq(nq+1),tqdot(nq),tg(*) + dimension tr(nq+ng+1) + + +c + do 199 i=1,nq +c +c -- calcul du terme general -- +c + if (i.eq.1) then + call lq(nq,tq,tr,tg,ng) +c . tlq =tr(1:nq); tvq =tr(nq+1:nq+ng+1) + ltlq=1 + ltvq=nq+1 +c +c division de tvq par q + call dpodiv(tr(ltvq),tq,ng,nq) + nv=ng-nq + else + ichoix=1 + call mzdivq(ichoix,nv,tr(ltvq),nq,tq) + endif +c +c calcul de tvq~ sur place + nr=nq-1 + call tild(nr,tr(ltvq),tr) + call calsca(nq,tq,tr,y0,tg,ng) +c +c -- conclusion -- +c + tqdot(i)=-2.0d+0*y0 +c + 199 continue +c write(6,'(''tqdot='',5(e10.3,2x))') (tqdot(i),i=1,nq) +c + return + end diff --git a/modules/cacsd/src/fortran/feq.lo b/modules/cacsd/src/fortran/feq.lo new file mode 100755 index 000000000..542791cf3 --- /dev/null +++ b/modules/cacsd/src/fortran/feq.lo @@ -0,0 +1,12 @@ +# src/fortran/feq.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/feq.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/fout.f b/modules/cacsd/src/fortran/fout.f new file mode 100755 index 000000000..5cf0e37ae --- /dev/null +++ b/modules/cacsd/src/fortran/fout.f @@ -0,0 +1,37 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + integer function fout(lsize,alpha,beta,s,p) + + integer lsize + double precision alpha,beta,s,p +c!purpose +c this function checks if +c the real root alpha/beta lies outside the unit disc +c (if lsize=1) +c the complex conjugate roots with sum s and product p lie +c outside the unit disc (if lsize=2). +c if so, fout=1, otherwise, fout=-1 +c in this function the parameter s is not referenced +c +c!calling sequence +c +c integer function fout(lsize,alpha,beta,s,p) +c integer lsize +c double precision alpha,beta,s,p +c!auxiliary routines +c abs (fortran) +c! + fout=-1 + if(lsize.eq.2) go to 2 + if(abs(alpha).ge.abs(beta)) fout=1 + return + 2 if(abs(p).ge.1.) fout=1 + return + end diff --git a/modules/cacsd/src/fortran/fout.lo b/modules/cacsd/src/fortran/fout.lo new file mode 100755 index 000000000..170f7ec24 --- /dev/null +++ b/modules/cacsd/src/fortran/fout.lo @@ -0,0 +1,12 @@ +# src/fortran/fout.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fout.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/front.f b/modules/cacsd/src/fortran/front.f new file mode 100755 index 000000000..f8e825215 --- /dev/null +++ b/modules/cacsd/src/fortran/front.f @@ -0,0 +1,56 @@ + +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine front(nq,tq,nbout,w) +C!but +C cette routine calcule le nombre de racines du polynome q(z) qui +C sont situees a l'exterieur du cercle unite . +C!liste d'appel +C subroutine front(nq,tq,nbout,w) +C dimension tq(0:*),w(*) +C Entree : +C - nq . est le degre du polynome q(z) +C - tq . le tableau du polynome en question +C +C Sortie : +C -nbout . est le nombre de racine a l'exterieur du du cercle unite +C tableau de travail +C -w 3*nq+1 +C! + + implicit double precision (a-h,o-z) + dimension tq(nq+1), w(*) +C + integer fail +C + lpol = 1 + lzr = lpol + nq + 1 + lzi = lzr + nq + lzmod = lpol + lfree = lzi + nq +C + call dcopy(nq+1,tq,1,w(lpol),-1) + call rpoly(w(lpol),nq,w(lzr),w(lzi),fail) + call modul(nq,w(lzr),w(lzi),w(lzmod)) +C + nbout = 0 + nbon = 0 + do 110 i = 1,nq + if (w(lzmod-1+i) .gt. 1.0d+0) then + nbout = nbout + 1 + endif + if (w(lzmod-1+i) .eq. 1.0d+0) then + nbon = nbon + 1 + endif + 110 continue +C + return + end + diff --git a/modules/cacsd/src/fortran/front.lo b/modules/cacsd/src/fortran/front.lo new file mode 100755 index 000000000..f18f84416 --- /dev/null +++ b/modules/cacsd/src/fortran/front.lo @@ -0,0 +1,12 @@ +# src/fortran/front.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/front.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/giv.f b/modules/cacsd/src/fortran/giv.f new file mode 100755 index 000000000..ccd59e8e0 --- /dev/null +++ b/modules/cacsd/src/fortran/giv.f @@ -0,0 +1,53 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine giv(sa,sb,sc,ss) + + double precision sa,sb,sc,ss +c!purpose +c this routine constructs the givens transformation +c +c ( sc ss ) +c g = ( ), sc**2+ss**2 = 1. , +c (-ss sc ) +c +c which zeros the second entry of the 2-vector (sa,sb)**t +c this routine is a modification of the blas routine srotg +c (algorithm 539) in order to leave the arguments sa and sb +c unchanged +c +c!calling sequence +c +c subroutine giv(sa,sb,sc,ss) +c double precision sa,sb,sc,ss +c!auxiliary routines +c sqrt abs (fortran) +c! + double precision r,u,v + if(abs(sa).le.abs(sb)) go to 10 +c* here abs(sa) .gt. abs(sb) + u=sa+sa + v=sb/u + r=sqrt(0.250d+0+v*v)*u + sc=sa/r + ss=v*(sc+sc) + return +c* here abs(sa) .le. abs(sb) + 10 if(sb.eq.0.0d+0) go to 20 + u=sb+sb + v=sa/u + r=sqrt(0.250d+0+v*v)*u + ss=sb/r + sc=v*(ss+ss) + return +c* here sa = sb = 0. + 20 sc=1.0d+0 + ss=0.0d+0 + return + end diff --git a/modules/cacsd/src/fortran/giv.lo b/modules/cacsd/src/fortran/giv.lo new file mode 100755 index 000000000..3fa9c2560 --- /dev/null +++ b/modules/cacsd/src/fortran/giv.lo @@ -0,0 +1,12 @@ +# src/fortran/giv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/giv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/hessl2.f b/modules/cacsd/src/fortran/hessl2.f new file mode 100755 index 000000000..3f7ee62d0 --- /dev/null +++ b/modules/cacsd/src/fortran/hessl2.f @@ -0,0 +1,166 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine hessl2(neq,tq,pd,nrowpd) +c!but +c Elle etablit la valeur de la Hessienne, derivee +c seconde de la fonction phi au point q . +c!liste d'appel +c subroutine hessl2(neq,tq,pd,nrowpd) +c Entree : +c - neq. tableau entier de taille 3+(nq+1)*(nq+2) +c neq(1)=nq est le degre effectif du polynome tq (ou q). +c neq(2)=ng est le nombre de coefficient de fourier +c neq(3)=dgmax degre maximum pour q (l'adresse des coeff de fourier dans +c tq est neq(3)+2 +c neq(4:(nq+1)*(nq+2)) tableau de travail entier +c - tq. tableau reel de taille au moins +c 6+dgmax+5*nq+6*ng+nq*ng+nq**2*(ng+1) +c tq(1:nq+1) est le tableau des coefficients du polynome. +c tq(dgmax+2:dgmax+ng+2) est le tableau des coefficients +c de fourier +c tq(dgmax+ng+3:) est un tableau de travail de taille au moins +c 5+5*nq+5*ng+nq*ng+nq**2*(ng+1) +c Sortie : +c - pd matrice hessienne +c! + + implicit double precision (a-h,o-y) + dimension tq(*),pd(nrowpd,*) + dimension neq(*) +c + nq=neq(1) + ng=neq(2) +c +c decoupage du tableau neq + jmxnv=4 + jmxnw=jmxnv+(nq+1) + jw=jmxnw+(nq+1)**2 +c +c decoupage du tableau tq + itq=1 + itg=itq+neq(3)+1 + itr=itg+ng+1 + itp=itr+nq+ng+1 + itv=itp+nq+ng+1 + itw=itv+nq+ng+1 + itij=itw+nq+ng+1 + id1aux=itij+ng+1 + id2aux=id1aux+(ng+1)*nq + iw=id2aux+nq*nq*(ng+1) + + call hl2(nq,tq,tq(itg),ng,pd,nrowpd,tq(itr), + $ tq(itp),tq(itv),tq(itw),tq(itij),tq(id1aux),tq(id2aux), + $ neq(jmxnv),neq(jmxnw)) + return + end + + + + subroutine hl2(nq,tq,tg,ng,pd,nrowpd,tr,tp,tv,tw,tij,d1aux,d2aux, + & maxnv,maxnw) +c! + + implicit double precision (a-h,o-y) + dimension tq(nq+1),tg(ng+1),pd(nrowpd,*) +c + dimension tr(nq+ng+1),tv(nq+ng+1),tp(nq+ng+1),tw(nq+ng+1), + & tij(ng+1),d1aux(ng+1,nq),d2aux(nq,nq,ng+1) + integer maxnv(nq),maxnw(nq,nq) +c +c --- Calcul des derivees premieres de 'vq' --- +c + do 20 i=1,nq + if (i.eq.1) then +c . division euclidienne de z^nq*g par q + call dset(nq,0.0d0,tp,1) + call dcopy(ng+1,tg,1,tp(nq+1),1) + call dpodiv(tp,tq,nq+ng,nq) + nv1=ng +c . calcul de Lq et Vq + call lq(nq,tq,tr,tg,ng) + ltvq=nq+1 +c . division euclidienne de Vq par q + call dcopy(ng+1,tr(ltvq),1,tv,1) + call dset(nq,0.0d0,tv(ng+2),1) + call dpodiv(tv,tq,ng,nq) + nv2=ng-nq + else + ichoi1=1 + call dzdivq(ichoi1,nv1,tp,nq,tq) + ichoi2=2 + call mzdivq(ichoi2,nv2,tv,nq,tq) + endif + maxnv(i)=max(nv1,nv2) + do 10 j=1,maxnv(i)+1 + d1aux(j,i)= tp(nq+j)-tv(nq+j) + 10 continue + 20 continue +c +c --- Calcul des derivees secondes de 'vq' --- +c + do 50 i=1,nq + call dset(ng+nq+1,0.0d0,tw,1) + do 40 j=nq,1,-1 + if (j.eq.nq) then + call dcopy(maxnv(i)+1,d1aux(1,i),1,tw(nq),1) + nw=maxnv(i)+nq-1 + call dpodiv(tw,tq,nw,nq) + nw=nw-nq + else + ichoix=1 + call dzdivq(ichoix,nw,tw,nq,tq) + endif + do 30 k=1,nw+1 + d2aux(i,j,k)=tw(nq+k) + 30 continue + maxnw(i,j)=nw + 40 continue + 50 continue +c +c --- Conclusion des calculs sur la hessienne --- +c + do 100 i=1,nq + do 90 j=1,i + call scapol(maxnv(i),d1aux(1,i),maxnv(j), + & d1aux(1,j),y1) +c + if (maxnw(i,j).gt.maxnw(j,i)) then + maxij=maxnw(i,j) + minij=maxnw(j,i) + do 60 k=minij+2,maxij+1 + tij(k)= -d2aux(i,j,k) + 60 continue + else if (maxnw(i,j).lt.maxnw(j,i)) then + maxij=maxnw(j,i) + minij=maxnw(i,j) + do 70 k=minij+2,maxij+1 + tij(k)= -d2aux(j,i,k) + 70 continue + else + maxij=maxnw(i,j) + minij=maxij + endif +c + do 80 k=1,minij+1 + tij(k)= -d2aux(i,j,k) -d2aux(j,i,k) + 80 continue +c + call scapol(maxij,tij,ng,tr(ltvq),y2) + + if (i.eq.j) then + pd(i,i)=-2.0d+0 * (y1+y2) + else + pd(i,j)=-2.0d+0 * (y1+y2) + pd(j,i)=-2.0d+0 * (y1+y2) + endif + 90 continue + 100 continue + return + end diff --git a/modules/cacsd/src/fortran/hessl2.lo b/modules/cacsd/src/fortran/hessl2.lo new file mode 100755 index 000000000..e74c229d4 --- /dev/null +++ b/modules/cacsd/src/fortran/hessl2.lo @@ -0,0 +1,12 @@ +# src/fortran/hessl2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/hessl2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/jacl2.f b/modules/cacsd/src/fortran/jacl2.f new file mode 100755 index 000000000..6f263798d --- /dev/null +++ b/modules/cacsd/src/fortran/jacl2.f @@ -0,0 +1,101 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine jacl2(neq,t,tq,ml,mu,pd,nrowpd) +c!but +c jacl2 cree la matrice jacobienne necessaire a Lsoda, +c qui correspond en fait a la hessienne du probleme +c d'approximation L2. +c!liste d'appel +c entree : +c - neq. tableau entier de taille 3+(nq+1)*(nq+2) +c neq(1)=nq est le degre effectif du polynome q +c neq(2)=ng est le nombre de coefficient de fourier +c neq(3)=dgmax degre maximum pour q (l'adresse des coeff de +c fourier dans tq est neq(3)+2 +c neq(4:(nq+1)*(nq+2)) tableau de travail entier +c - t est une variable parametrique necessaire a Lsoda. +c - tq. tableau reel de taille au moins +c 7+dgmax+5*nq+6*ng+nq*ng+nq**2*(ng+1) +c tq(1:nq+1) est le tableau des coefficients du polynome q. +c tq(dgmax+2:dgmax+ng+2) est le tableau des coefficients +c de fourier +c tq(dgmax+ng+3:) est un tableau de travail de taille au moins +c 5+5*nq+5*ng+nq*ng+nq**2*(ng+1) +c - ml et mu sont les parametres du stockage par bande +c de la matrice qui n a pas lieu ici ,ils donc ignores. +c +c sortie : +c - pd. est le tableau ou l on range la matrice pleine +c dont les elements sont etablis par la sub. Hessien +c - nrowpd. est le nombre de ligne du tableau pd +c! + + implicit double precision (a-h,o-y) + dimension tq(*),pd(nrowpd,*) + dimension neq(*) + +c + call hessl2(neq,tq,pd,nrowpd) + nq=neq(1) +c write(6,'(''jac='')') +c do 10 i=1,nq +c write(6,'(5(e10.3,2x))') (pd(i,j),j=1,nq) +c 10 continue +c + return + end + subroutine jacl2n(neq,t,tq,ml,mu,pd,nrowpd) +c!but +c jacl2 cree la matrice jacobienne necessaire a Lsoda, +c qui correspond en fait a la hessienne du probleme +c d'approximation L2. +c!liste d'appel +c entree : +c - neq. tableau entier de taille 3+(nq+1)*(nq+2) +c neq(1)=nq est le degre effectif du polynome q +c neq(2)=ng est le nombre de coefficient de fourier +c neq(3)=dgmax degre maximum pour q (l'adresse des coeff de +c fourier dans tq est neq(3)+2 +c neq(4:(nq+1)*(nq+2)) tableau de travail entier +c - t est une variable parametrique necessaire a Lsoda. +c - tq. tableau reel de taille au moins +c 7+dgmax+5*nq+6*ng+nq*ng+nq**2*(ng+1) +c tq(1:nq+1) est le tableau des coefficients du polynome q. +c tq(dgmax+2:dgmax+ng+2) est le tableau des coefficients +c de fourier +c tq(dgmax+ng+3:) est un tableau de travail de taille au moins +c 5+5*nq+5*ng+nq*ng+nq**2*(ng+1) +c - ml et mu sont les parametres du stockage par bande +c de la matrice qui n a pas lieu ici ,ils donc ignores. +c +c sortie : +c - pd. est le tableau ou l on range la matrice pleine +c dont les elements sont etablis par la sub. Hessien +c - nrowpd. est le nombre de ligne du tableau pd +c! + implicit double precision (a-h,o-y) + dimension tq(*),pd(nrowpd,*) + dimension neq(*) + +c + call hessl2(neq,tq,pd,nrowpd) + nq=neq(1) + do 20 i=1,nq + do 10 j=1,nq + pd(i,j)=-pd(i,j) + 10 continue + 20 continue +c write(6,'(''jac='')') +c do 10 i=1,nq +c write(6,'(5(e10.3,2x))') (pd(i,j),j=1,nq) +c 10 continue +c + return + end diff --git a/modules/cacsd/src/fortran/jacl2.lo b/modules/cacsd/src/fortran/jacl2.lo new file mode 100755 index 000000000..d92b7996d --- /dev/null +++ b/modules/cacsd/src/fortran/jacl2.lo @@ -0,0 +1,12 @@ +# src/fortran/jacl2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/jacl2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/linpack_f_Import.def b/modules/cacsd/src/fortran/linpack_f_Import.def new file mode 100755 index 000000000..710eac24a --- /dev/null +++ b/modules/cacsd/src/fortran/linpack_f_Import.def @@ -0,0 +1,11 @@ +LIBRARY linpack_f.dll + + +EXPORTS +dgeco_ +dgedi_ +dgefa_ +dgesl_ +icopy_ +wgeco_ +wgesl_ diff --git a/modules/cacsd/src/fortran/lq.f b/modules/cacsd/src/fortran/lq.f new file mode 100755 index 000000000..509f58b81 --- /dev/null +++ b/modules/cacsd/src/fortran/lq.f @@ -0,0 +1,47 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine lq(nq,tq,tr,tg,ng) +c!but +c cette routine calcule a partir de g(z) et q(z) le +c polynome Lq(z) defini comme le reste , tilde , de la division +c par q(z) du produit g(z) par le tilde de q(z) . +c!liste d'appel +c Entree : +c tg . tableau des coefficients de la fonction g . +c ng . degre du polynome g +c tq . tableau des coefficients du polynome q +c nq . degre du polynome q +c Sortie : +c tr . tableau [tlq,tvq] +c tlq =tr(1:nq) coefficients du polynome Lq +c tvq =tr(nq+1:nq+ng+1) coefficients du quotient vq de la +c division par q du polynome gqti . +c! + + + implicit double precision (a-h,o-z) + dimension tq(nq+1),tr(nq+ng+1),tg(ng+1) +c +c calcul de tg*tq~ + call tild (nq,tq,tr) + call dpmul1(tg,ng,tr,nq,tr) +c +c division euclidienne de tg*tq~ par tq + call dpodiv(tr,tq,ng+nq,nq) +c +c calcul du tilde du reste sur place + do 10 j=1,int(nq/2) + temp=tr(j) + tr(j)=tr(nq+1-j) + tr(nq+1-j)=temp + 10 continue +c + return + end diff --git a/modules/cacsd/src/fortran/lq.lo b/modules/cacsd/src/fortran/lq.lo new file mode 100755 index 000000000..639e6b432 --- /dev/null +++ b/modules/cacsd/src/fortran/lq.lo @@ -0,0 +1,12 @@ +# src/fortran/lq.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/lq.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/modul.f b/modules/cacsd/src/fortran/modul.f new file mode 100755 index 000000000..f9539497b --- /dev/null +++ b/modules/cacsd/src/fortran/modul.f @@ -0,0 +1,32 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine modul(neq,zeror,zeroi,zmod) +c!but +c ce sous programme calcule le vecteur des modules d'un vecteur +c de nombres complexes +c!liste d'appel +c subroutine modul(neq,zeror,zeroi,zmod) +c double precision zeror(neq),zeroi(neq),zmod(neq) +c +c neq : longueur des vecteurs +c zeror (zeroi) : vecteurs des parties reelles (imaginaires) du +c vecteur de nombres complexes +c zmod : vecteur des modules +c! + + implicit double precision (a-h,o-z) + dimension zeror(*),zeroi(*),zmod(*) +c + do 50 i=1,neq+1 + zmod(i)= sqrt( zeror(i)**2 + zeroi(i)**2 ) + 50 continue +c + return + end diff --git a/modules/cacsd/src/fortran/modul.lo b/modules/cacsd/src/fortran/modul.lo new file mode 100755 index 000000000..fca86d0dc --- /dev/null +++ b/modules/cacsd/src/fortran/modul.lo @@ -0,0 +1,12 @@ +# src/fortran/modul.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/modul.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/mzdivq.f b/modules/cacsd/src/fortran/mzdivq.f new file mode 100755 index 000000000..cae1c7780 --- /dev/null +++ b/modules/cacsd/src/fortran/mzdivq.f @@ -0,0 +1,63 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine mzdivq(ichoix,nv,tv,nq,tq) +c!but +c cette routine calcule, lorsque l'on connait le quotient et le reste +c de la division par q d'un polynome, le reste et le quotient de +c la division par q de ce polynome multiplie par z. +c!liste d'appel +c +c subroutine mzdivq(ichoix,nv,tv,nq,tq) +c +c entree : +c - ichoix. le nouveau reste ne sequential calculant +c qu'avec le reste precedent, ce qui n'est pas le cas du +c quotient, la possibilite est donnee de ne calculer que +c ce reste. ichoix=1 .Si l'on desire calculer aussi le +c quotient, ichoix=2. +c - nv. est le degre du quotient entrant tv. +c - tv. est le tableau contenant les coeff. du quotient. +c - tr. est le tableau contenant les coeff. du reste de +c degre nq-1. +c - nq. est le degre du polynome tq. +c - tq. est le tableau contenant les coeff. du pol. tq. +c +c sortie : +c - nv. est le degre du nouveau quotient. +c - tv. contient les coeff. du nouveau quotient. +c - tr. ceux du nouveau reste de degre toujours nq-1. +c! + + implicit double precision (a-h,o-y) + dimension tv(0:*),tq(0:*) +c + raux=tv(nq-1) +c +c -- Calcul du nouveau reste ------------- +c + do 20 i=nq-1,1,-1 + tv(i)= tv(i-1) - tq(i)*raux + 20 continue +c + tv(0)= -tq(0)*raux +c + if (ichoix.eq.1) return +c +c -- Calcul du nouveau quotient ---------- +c + do 30 i=nq+nv,nq,-1 + tv(i+1)=tv(i) + 30 continue +c + tv(nq)=raux + nv=nv+1 +c + return + end diff --git a/modules/cacsd/src/fortran/mzdivq.lo b/modules/cacsd/src/fortran/mzdivq.lo new file mode 100755 index 000000000..06953b06b --- /dev/null +++ b/modules/cacsd/src/fortran/mzdivq.lo @@ -0,0 +1,12 @@ +# src/fortran/mzdivq.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mzdivq.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/onface.f b/modules/cacsd/src/fortran/onface.f new file mode 100755 index 000000000..2bd49e23d --- /dev/null +++ b/modules/cacsd/src/fortran/onface.f @@ -0,0 +1,177 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine onface(nq,tq,tg,ng,nprox,ierr,w) +C!but +C il est question ici de calculer (ou d estimer) +C le polynome (ou point) qui se situe a l'intersection +C de la recherche et de la face-frontiere du domaine. +C!liste d'appel +C subroutine onface(nq,tq,nprox) +C +C double precision tq(0:nq),w(*) +C integer nq,nprox,ierr +C +C Entree : +C - nq. est le degre du polynome q(z) avant toute +C modification. +C - tq. est le tableau de ses coefficients +C - nprox. est l indice de la face par laquelle on estime +C que la recherche a franchi la frontiere du domaine. +C +C Sortie : +C -nq. est alors le degre des polynomes de la face +C traversee et donc du polynome intersection. Sa valeur +C est inferieur de 1 ou 2 a sa valeur precedente. +C - tq. contient en sortie les coefficients du polynome +C intersection dans le domaine de la face traversee. +C +C Tableau de travail +C - w : 12*nq+ng+1 +C! + implicit double precision (a-h,o-y) + dimension tq(0:nq), w(*),tg(ng+1) +C + dimension tps(0:1), taux2(0:2), tabeta(0:2), xx(1) + common /sortie/ io,info,ll +C +C decoupage du tableau de travail + lqaux = 1 + lqdot = lqaux + lrq0 = lqdot + nq + 1 + lrq1 = lrq0 + nq + lrgd0 = lrq1 + nq + lrgd1 = lrgd0 + nq + lgp = lrgd1 + nq + lgp1 = lgp + 2*nq - 2 + lbeta = lgp1 + lw = lbeta + 2*nq - 2 + lfree = lw+3*nq+ng+1 + +C + nqvra = nq +C + tps(1) = 1.0d+0 + tps(0) = 1.0d+0 +C + if (nprox .ne. 0) then + tps(0) = real(nprox) +C calcul du reste de la division de q par tps + call horner(tq,nq,-tps(0),0.0d+0,srq,xx) +C calcul du reste de la division de qdot par 1+z + call feq1(nq,t,tq,tg,ng,w(lqdot),w(lw)) + call horner(w(lqdot),nq,-tps(0),0.0d+0,srgd,xx) +C + call daxpy(nq,(-srq)/srgd,w(lqdot),1,tq,1) +C + call dpodiv(tq,tps,nq,1) + if (info .gt. 0) call outl2(70,1,1,xx,xx,x,x) + if (info .gt. 1) call outl2(71,1,1,tq,xx,x,x) + call dcopy(nq,tq(1),1,tq,1) + nq = nq - 1 +C + elseif (nprox .eq. 0) then +C + taux2(2) = 1.0d+0 + taux2(1) = 0.0d+0 + taux2(0) = 1.0d+0 +C + call dcopy(nq+1,tq,1,w(lqaux),1) + do 200 ndiv = 0,nq-2 + call dpodiv(w(lqaux),taux2,nq-ndiv,2) + w(lrq1+ndiv) = w(lqaux+1) + w(lrq0+ndiv) = w(lqaux) +C + do 180 j = 2,nq-ndiv + w(lqaux+j-1) = w(lqaux+j) + 180 continue + w(lqaux) = 0.0d+0 + 200 continue + w(lrq1-1+nq) = w(lqaux+1) + w(lrq0-1+nq) = w(lqaux) +C + call feq1(nq,t,tq,tg,ng,w(lqaux),w(lw)) + nqdot = nq - 1 +C + do 240 ndiv = 0,nqdot-2 + call dpodiv(w(lqaux),taux2,nqdot-ndiv,2) + w(lrgd1+ndiv) = w(lqaux+1) + w(lrgd0+ndiv) = w(lqaux) +C + do 220 j = 2,nqdot-ndiv + w(lqaux+j-1) = w(lqaux+j) + 220 continue + w(lqaux) = 0.0d+0 + 240 continue + w(lrgd1-1+nqdot) = w(lqaux+1) + w(lrgd0-1+nqdot) = w(lqaux) +C +C - construction du polynome gp(z) dont on cherchera une racine +C comprise entre -2 et +2 ----------------------------- +C + call dset(2*nq-2,0.0d+0,w(lgp),1) + call dset(2*nq-2,0.0d+0,w(lgp1),1) +C + do 260 j = 1,nq + do 258 i = 1,nqdot + k = i + j - 2 + w(lgp+k) = w(lgp+k) + ((-1)**k)*w(lrq0-1+j)*w(lrgd1-1+i) + w(lgp1+k) = w(lgp1+k) + ((-1)**k)*w(lrq1-1+j)*w(lrgd0-1+i) + 258 continue + 260 continue +C + call ddif(2*nq-2,w(lgp1),1,w(lgp),1) + ngp = 2*nq - 3 + call rootgp(ngp,w(lgp),nbeta,w(lbeta),ierr,w(lw)) + if (ierr .ne. 0) return +C + do 299 k = 1,nbeta +C +C - calcul de t (coeff multiplicateur) - +C + auxt1 = 0.0d+0 + do 280 i = 1,nq + auxt1 = auxt1 + w(lrq1-1+i)*((-w(lbeta-1+k))**(i-1)) + 280 continue +C + auxt2 = 0.0d+0 + do 290 i = 1,nqdot + auxt2 = auxt2 + w(lrgd1-1+i)*((-w(lbeta-1+k))**(i-1)) + 290 continue +C + tmult = (-auxt1) / auxt2 +C + if (k .eq. 1) then + t0 = tmult + beta0 = w(lbeta) + elseif (abs(tmult) .lt. abs(t0)) then + t0 = tmult + beta0 = w(lbeta-1+k) + endif +C + 299 continue +C + call feq1(nq,t,tq,tg,ng,w(lqdot),w(lw)) + call daxpy(nq,t0,w(lqdot),1,tq,1) +C + tabeta(2) = 1.0d+0 + tabeta(1) = beta0 + tabeta(0) = 1.0d+0 + call dpodiv(tq,tabeta,nq,2) + if (info .gt. 0) call outl2(70,2,2,xx,xx,x,x) + if (info .gt. 1) call outl2(71,2,2,tq,xx,x,x) +C + call dcopy(nq-1,tq(2),1,tq,1) + nq = nq - 2 +C + endif +C + return + end + diff --git a/modules/cacsd/src/fortran/onface.lo b/modules/cacsd/src/fortran/onface.lo new file mode 100755 index 000000000..6473c0bfa --- /dev/null +++ b/modules/cacsd/src/fortran/onface.lo @@ -0,0 +1,12 @@ +# src/fortran/onface.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/onface.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/optml2.f b/modules/cacsd/src/fortran/optml2.f new file mode 100755 index 000000000..e80fdd816 --- /dev/null +++ b/modules/cacsd/src/fortran/optml2.f @@ -0,0 +1,275 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine optml2(feq,jacl2,neq,q,nch,w,iw) +C!but +C Routine de recherche de minimum du probleme d'approximation L2 +C par lsoda ( Lsoda = routine de resolution d'equa diff ) +C!liste d'appel +C subroutine optml2(feq,jacl2,neq,q,nch,w,iw) +C +C external feq,jacl2 +C double precision q(*),w(*) +C integer nch,iw(*) +C +C Entrees : +C - feq est la subroutine qui calcule le gradient, +C oppose de la derivee premiere de la fonction phi. +c - neq. tableau entier de taille 3+(npara+1)*(npara+2) +c neq(1)=nq est le degre effectif du polynome q. +c neq(2)=ng est le nombre de coefficient de fourier +c neq(3)=dgmax degre maximum pour q (l'adresse des coeff de fourier dans +c q est neq(3)+2 +C - neq est le degre du polynome q +c - tq. tableau reel de taille au moins +c 6+dgmax+5*nq+6*ng+nq*ng+nq**2*(ng+1) +c tq(1:nq+1) est le tableau des coefficients du polynome q. +c tq(dgmax+2:dgmax+ng+2) est le tableau des coefficients +c de fourier +c tq(dgmax+ng+3:) est un tableau de travail de taille au moins +c 5+5*nq+5*ng+nq*ng+nq**2*(ng+1) +C - nch est l indice (valant 1 ou 2) qui classifie l +C appel comme etant soit celui de la recherche et de la +C localisation d un minimum local, soit de la +C confirmation d un minimum local. +C +C Sorties : +C - neq est toujours le degre du polynome q (il peut avoir varie). +C - q est le polynome (ou plutot le tableau contenant +C ses coefficients) qui resulte de la recherche ,il peut +C etre du meme degre que le polynome initial mais aussi +C de degre inferieur dans le cas d'une sortie de face. +C +C Tableau de travail +C - w de taille 25+26*nq+ng+nq**2 +C - iw de taille 20+nq +C! + + implicit double precision (a-h,o-y) + dimension q(*), w(*), iw(*), xx(1) + integer neq(*) + double precision x,phi0,phi,gnrm +C + external feq, jacl2 + common /temps/ t + common /comall/ nall1 /sortie/ io,info,ll + common /no2f/ gnrm +c + nq=neq(1) + ng=neq(2) + ltg=1+neq(3) +C +c taille des tableaux de travail necessaires a lsode + lrw = nq**2 + 9*nq + 22 + liw = 20+nq + +C decoupage du tableau de travail w + lqi = 1 + lqdot = lqi + nq + 1 + latol = lqdot + nq + lrtol = latol + nq + lwork = lrtol + nq + lfree = lwork + 24+22*nq+ng+nq**2 +c + lw = lwork + lrw + +C decoupage du tableau de travail iw + liww=1 + lifree=liww+liw +C + nqbac = nq +C +C --- Initialisation de lsode ------------------------ +C + if (nch .eq. 1) t = 0.0d+0 + t0 = t + tt = 0.10d+0 + tout = t0 + tt + itol = 4 +C + if (nq .lt. 7) then + ntol = int((nq-1)/3) + 5 + else + ntol = int((nq-7)/2) + 7 + endif + call dset(nq,10.0d+0**(-(ntol)),w(lrtol),1) + call dset(nq,10.0d+0**(-(ntol+2)),w(latol),1) +C + itask = 1 + if (nch .eq. 1) istate = 1 + if (nch .eq. 2) istate = 3 + iopt = 0 + mf = 21 +C +C --- Initialisation du nombre maximal d'iteration --- +C + if (nch .eq. 1) then + if (nq .le. 11) then + nlsode = 11 + 2*(nq-1) + else + nlsode = 29 + endif + else + nlsode = 19 + endif + ilcom = 0 + ipass = 0 +C +C --- Appel de lsode -------------------------------- +C + 210 do 290 i = 1,nlsode +C + 220 ilcom = ilcom + 1 +C +C -- Reinitialisation de la Tolerance -- +C + if (ilcom.eq.2 .and. nch.eq.1) then + call dset(nq,1.0d-05,w(lrtol),1) + call dset(nq,1.0d-07,w(latol),1) + istate = 3 + elseif (ilcom.eq.2 .and. nch.eq.2) then + w(lrtol) = 1.0d-08 + w(latol) = 1.0d-10 + w(lrtol+1) = 1.0d-07 + w(latol+1) = 1.0d-09 + w(lrtol+nq-1) = 1.0d-05 + w(latol+nq-1) = 1.0d-07 + do 240 j = 2,nq-2 + w(lrtol+j) = 1.0d-06 + w(latol+j) = 1.0d-08 + 240 continue + istate = 3 + endif +C +C -------------------------------------- +C + call dcopy(nq+1,q,1,w(lqi),1) + ti = t + touti = tout +C + if (info .gt. 1) call outl2(30,nq,nq,q,xx,t,tout) +C + + call lsode(feq,neq,q,t,tout,itol,w(lrtol),w(latol),itask, + & istate,iopt,w(lwork),lrw,iw(liww),liw,jacl2,mf) +C + call front(nq,q,nbout,w(lw)) +C + call feq(neq,t,q,w(lqdot)) + dnorm0 = dnrm2(nq,w(lqdot),1) + if (info .gt. 1) call outl2(31,nq,nbout,q,dnorm0,t,tout) +C +C -- test pour degre1 ----------- + if (nall1.gt.0 .and. nq.eq.1 .and. nbout.gt.0) return +C +C +C -- Istate de lsode ------------ +C + if (istate .eq. -5) then + if (info .gt. 0) call outl2(32,nq,nq,xx,xx,x,x) + call dscal(nq,0.10d+0,w(lrtol),1) + call dscal(nq,0.10d+0,w(latol),1) + if (t .eq. 0.0d+0) istate = 1 + if (t .ne. 0.0d+0) istate = 3 + ilcom = 0 + goto 220 + endif +C + if (istate .eq. -6) then +C echec de l'integration appel avec de nouvelles tolerances + if (info .gt. 0) call outl2(33,nq,nq,xx,xx,x,x) + if (info .gt. 1) + & call outl2(34,nq,itol,w(latol),w(lrtol),t,tout) + iopt = 0 + itol = 4 + call dset(nq,0.10d-05,w(lrtol),1) + call dset(nq,0.10d-05,w(latol),1) + if (info .gt. 1) call outl2(35,nq,itol,w(latol),w(lrtol),x,x) + if (info .gt. 0) call outl2(36,nq,nq,xx,xx,x,x) + istate = 3 + if (t .ne. tout) goto 220 + endif +C + if (istate.lt.-1 .and. istate.ne.-6 .and. istate.ne.-5) then + if (info .gt. 0) call outl2(37,nq,iopt,xx,xx,x,x) + nch = 15 + return + endif +C +C ------------------------------- +C +C -- Sortie de face ------------- +C + if (nbout.gt.0 .and. nbout.ne.99) then + call domout(neq,q,w(lqi),nbout,ti,t,itol,w(lrtol), + & w(latol),itask,istate,iopt,w(lwork),lrw,iw(liww),liw, + & jacl2,mf,job) + nq=neq(1) + if (job .eq. -1) then +C anomalie dans la recherche de l'intersection + nch = 16 + return + endif + if (job .eq. 1) then + nch = nq - nqbac + return + endif + endif +C +C ------------------------------- +C +C -- test sur le gradient ------- +C + epstop = (1.0d-06)**nch + call feq(neq,t,q,w(lqdot)) + dnorm0 = dnrm2(nq,w(lqdot),1) + if (dnorm0 .lt. epstop) goto 299 +C +C ------------------------------- +C +C -- Istate de lsode (suite) ---- +C + if (istate.eq.-1 .and. t.ne.tout) then + if (info .gt. 0) call outl2(38,nq,nq,xx,xx,x,x) + istate = 2 + goto 220 + endif +C +C ------------------------------- +C + tt = sqrt(10.0d+0) * tt + tout = t0 + tt +C + 290 continue +C + if (nch.eq.2 .and. dnorm0.gt.(1.0d-06)) then + ipass = ipass + 1 + if (ipass .lt. 5) then + if (info .gt. 0) then + call lq(nq,q,w(lw),q(ltg),ng) + x=sqrt(gnrm) + call dscal(nq,x,w(lw),1) + call outl2(14,nq,nq,q,w(lw),x,x) + + phi0= abs(phi(q,nq,q(ltg),ng,w(lw))) + call feq(neq,t,q,w(lqdot)) + call outl2(17,nq,nq,q,w(lqdot),phi0,x) + endif + goto 210 + else + if (info .gt. 0) call outl2(39,nq,nq,xx,xx,x,x) + nch = 17 + return + endif + endif +C + 299 return +C + end + diff --git a/modules/cacsd/src/fortran/optml2.lo b/modules/cacsd/src/fortran/optml2.lo new file mode 100755 index 000000000..57ccae0f2 --- /dev/null +++ b/modules/cacsd/src/fortran/optml2.lo @@ -0,0 +1,12 @@ +# src/fortran/optml2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/optml2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/outl2.f b/modules/cacsd/src/fortran/outl2.f new file mode 100755 index 000000000..c0887e1f1 --- /dev/null +++ b/modules/cacsd/src/fortran/outl2.f @@ -0,0 +1,324 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine outl2(ifich,neq,neqbac,tq,v,t,tout) +c%but +c cette subroutine contient les differents messages +c a afficher suivant le deroulement de l execution. +c% liste d'appel +c Entrees : +c - ifich. est l'indice du message (-1 pour une +c intersection avec la face, 1 pour une localisation +c d un minimum local, 2 pour le resultat a un certain +c degre ...) +c - neq. est le degre (ou dimension) ou se situe +c la recherche actuelle. +c - neqbac. contient la valeur du degre avant le 1er +c appel de lsoda +c - tq. est le tableau contenant les coefficients du +c polynome. +c - w. trableau de travail +c +c Sortie : Aucune . +c% + + implicit double precision (a-h,o-y) + dimension tq(*),neq(*) + dimension v(*) + character*80 buf + common/no2f/ef2 + common/comall/nall/sortie/nwf,info,ll + + nq=neq(1) + +c +c + write(buf(1:3),'(i3)') neq(1) +c + if(ifich.ge.80) goto 400 + if(ifich.ge.70) goto 350 + if(ifich.ge.60) goto 300 + if(ifich.ge.50) goto 250 + if(ifich.ge.40) goto 200 + if(ifich.ge.30) goto 150 + if(ifich.ge.20) goto 100 + + ng=neq(2) + ltq = 1 + ltg = ltq+neq(3)+1 + ltqdot = ltg+ng+1+(nq+ng+1) + ltr=ltqdot+nq + lpd=ltr+ng+nq+1 + ltrti=lpd+nq*nq + lfree=ltrti+nq+1 + + if (ifich.lt.17) then + write(buf(1:3),'(i3)') nq + call basout(ifl,nwf,'----------------- TRACE AT ORDER: '// + $ buf(1:3)//' ----------------------') +c + if (ifich.lt.0) then + call basout(ifl,nwf,' Intersection with a degree '// + & buf(1:3)//' facet ') + else if (ifich.eq.1) then + call basout(ifl,nwf,' Minimum found for order: '// + $ buf(1:3)) + else if (ifich.eq.2) then + call basout(ifl,nwf,' Local minimum found for order: '// + $ buf(1:3)) + else if (ifich.eq.3) then + call basout(ifl,nwf,' Maximum found for order: '// + $ buf(1:3)) + else if (ifich.eq.4) then + call basout(ifl,nwf,' Local maximum found for order: '// + $ buf(1:3)) + else if (ifich.eq.14.or.ifich.eq.15.or.ifich.eq.16) then + call basout(ifl,nwf,' Reached point:') + endif +c + call basout(ifl,nwf,'Denominator:') + call dmdspf(tq,1,1,nq+1,15,ll,nwf) +c + call basout(ifl,nwf,'Numerator') + call dmdspf(v,1,1,nq,15,ll,nwf) + else +c + call basout(ifl,nwf,'Gradient :') + call dmdspf(v,1,1,nq,15,ll,nwf) + phi0=t + write(buf(1:14),'(d14.7)') phi0 + call basout(ifl,nwf,' Error L2 norm : '// + $ buf(1:14)) + write(buf(1:14),'(d14.7)') tout + call basout(ifl,nwf,' Datas L2 norm : '// + $ buf(1:14)) + errel= sqrt(phi0) + write(buf(1:14),'(d14.7)') errel + call basout(ifl,nwf,' Relative error norm : '// + $ buf(1:14)) + call basout(ifl,nwf,'------------------'// + $ '---------------------------------------------') + call basout(ifl,nwf, ' ') + call basout(ifl,nwf, ' ') + call basout(ifl,nwf,'------------------'// + $ '---------------------------------------------') + call basout(ifl,nwf, ' ') + call basout(ifl,nwf, ' ') + endif + 100 continue +c messages du sous programme arl2 + if(ifich.eq.20) then + call basout(ifl,nwf,'LSODE 1 '// + $ '------------------------------------------------------') + write(buf,'('' dg='',i2,'' dgback='',i2)') nq,neqbac + call basout(ifl,nwf,buf(1:30)) + else if(ifich.eq.21) then + call basout(ifl,nwf,'LSODE 2 '// + $ '------------------------------------------------------') + else if(ifich.eq.22) then + call basout(ifl,nwf, + $ ' Unwanted loop beetween two orders..., Stop') + else if(ifich.eq.23) then + write(buf(1:2),'(i2)') neqbac + call basout(ifl,nwf,'Il y a eu '//buf(1:2)// + $ ' retours de face.') + endif + return +c + 150 continue +c messages du sous programme optml2 + if(ifich.eq.30) then + call basout(ifl,nwf,'Optml2 =========='// + $ ' parameters before lsode call =================') + write(buf,'(2d14.7)') t,tout + call basout(ifl,nwf,' t= '//buf(1:14)// + $ ' tout= '//buf(15:28)) + call basout(ifl,nwf,' Q initial :') + call dmdspf(tq,1,1,nq+1,14,ll,nwf) + else if(ifich.eq.31) then + call basout(ifl,nwf,'Optml2 =========='// + $ ' parameters after lsode call ================') + write(buf,'(d14.7)') v(1) + call basout(ifl,nwf,' |grad|= '//buf(1:14)) + write(buf,'(i3)') neqbac + call basout(ifl,nwf,' nbout= '//buf(1:3)) + write(buf,'(2d14.7)') t,tout + call basout(ifl,nwf,' t= '//buf(1:14)// + $ ' tout= '//buf(15:28)) + call basout(ifl,nwf,' Q final :') + call dmdspf(tq,1,1,nq+1,14,ll,nwf) + call basout(ifl,nwf,'Optml2 ==========='// + $ ' End of LSODE description======================') + call basout(ifl,nwf,' ') + else if(ifich.eq.32) then + call basout(ifl,nwf,' Lsode: no convergence (istate=-5)') + call basout(ifl,nwf, 'new call with reduced tolerances') + else if(ifich.eq.33) then + call basout(ifl,nwf,' Lsode: no convergence (istate=-6)') + else if(ifich.eq.34) then + write(buf,'(2d14.7)') t,tout + call basout(ifl,nwf,' t= '//buf(1:14)// + $ ' tout= '//buf(15:28)) + write(buf,'(i5,d14.7)') neqbac,v(1) + call basout(ifl,nwf,' itol= '//buf(1:5)// + $ ' rtol= '//buf(6:19)) + call basout(ifl,nwf,'atol=') + call dmdspf(tq,1,1,nq,14,ll,nwf) + else if(ifich.eq.35) then + write(buf,'(i5,d14.7)') neqbac + call basout(ifl,nwf,' itol= '//buf(1:5)) + call basout(ifl,nwf,'rtol=') + call dmdspf(v,1,1,nq,14,ll,nwf) + call basout(ifl,nwf,'atol=') + call dmdspf(tq,1,1,nq,14,ll,nwf) + else if(ifich.eq.36) then + call basout(ifl,nwf, 'new call with increased tolerances') + else if(ifich.eq.37) then + write(buf(1:2),'(i2)') neqbac + call basout(ifl,nwf,' LSODE stops with istate ='//buf(1:2)) + else if(ifich.eq.38) then + call basout(ifl,nwf,' Lsode stops: too many integration '// + & 'steps (istate= -1)') + call basout(ifl,nwf,' new call to go further') + else if(ifich.eq.39) then + call basout(ifl,nwf, + $ 'Repeated LSODE failure -- OPTML2 stops') + endif + return + 200 continue +c message relatifs au sous programme domout + if(ifich.eq.40) then + call basout(ifl,nwf,' ') + call basout(ifl,nwf,'********LOOKING FOR INTERSECTION '// + $ ' WITH STABILITY DOMAIN BOUNDS ********') + write(buf(1:10),'(i10)') neqbac + call basout(ifl,nwf,' kmax= '//buf(1:10)) + else if(ifich.eq.41) then + call basout(ifl,nwf,'Domout =========='// + $ ' parameters before lsode call =================') + write(buf,'(2d14.7)') t,tout + call basout(ifl,nwf,' t= '//buf(1:14)// + $ ' tout= '//buf(15:28)) + call basout(ifl,nwf,' initial Q :') + call dmdspf(tq,1,1,nq+1,14,ll,nwf) + else if(ifich.eq.42) then + call basout(ifl,nwf,'Domout =========='// + $ ' parameters after lsode call =================') + write(buf,'(i3)') neqbac + call basout(ifl,nwf,' nbout= '//buf(1:3)) + write(buf,'(2d14.7)') t,tout + call basout(ifl,nwf,' t= '//buf(1:14)// + $ ' tout= '//buf(15:28)) + call basout(ifl,nwf,' Q final :') + call dmdspf(tq,1,1,nq+1,14,ll,nwf) + call basout(ifl,nwf,'Domout =========='// + $ ' End of LSODE description======================') + call basout(ifl,nwf,' ') + else if(ifich.eq.43) then + call basout(ifl,nwf,' Lsode stops: too many integration '// + & 'steps (istate= -1)') + call basout(ifl,nwf,' new call to go further') + else if(ifich.eq.44) then + write(buf(1:9),'(i9)') neqbac + call basout(ifl,nwf,'Number of unstable roots: '//buf(1:9)) + else if(ifich.eq.45) then + write(buf(1:3),'(i3)') neqbac + call basout(ifl,nwf,' lsode problem (istate='//buf(1:3)// + & ') when looking for intersection with ') + call basout(ifl,nwf,' stability domain bounds... Stop ') + else if(ifich.eq.46) then + write(buf(1:9),'(i9)') neqbac + call basout(ifl,nwf,'watface --> nface= '//buf(1:9)) + write(buf(1:9),'(i9)') nq + call basout(ifl,nwf,'onface --> neq= '//buf(1:9)) + write(buf,'(2d14.4)') t,tout + call basout(ifl,nwf,' yi= '//buf(1:14)// + $ ' yf= '//buf(15:28)) + call dmdspf(tq,1,1,nq+1,14,ll,nwf) + else if(ifich.eq.47) then + call basout(ifl,nwf,' goto 314 ===========================') + call basout(ifl,nwf,' qi = ') + call dmdspf(v,1,1,nq+1,14,ll,nwf) + else if(ifich.eq.47) then + call basout(ifl,nwf,'********END OF INTERSECTION '// + $ ' WITH STABILITY DOMAIN BOUNDS SEARCH ********') + endif + return +c + 250 continue +c messages de deg1l2 et degl2 + if(ifich.eq.50) then + call basout(ifl,nwf,' Non convergence ...') + call basout(ifl,nwf,' look for next solution .') + else if(ifich.eq.51) then + write(buf(1:3),'(i3)') nq + call basout(ifl,nwf,'+++++++++++++++++++++++++++++++++++++++'// + $ '++++++++++++++++++++++++') + Call basout(ifl,nwf,' Look for all minina of degree: ' + & //buf(1:3)) + call basout(ifl,nwf,'+++++++++++++++++++++++++++++++++++++++'// + $ '++++++++++++++++++++++++') + else if(ifich.eq.52) then + write(buf(1:3),'(i3)') nq + call basout(ifl,nwf,'+++++++++++++++++++++++++++++++++++++++'// + $ '++++++++++++++++++++++++') + Call basout(ifl,nwf,' End of search degree '//buf(1:3)// + $ ' minima ') + call basout(ifl,nwf,'+++++++++++++++++++++++++++++++++++++++'// + $ '++++++++++++++++++++++++') + mxsol=tout + call basout(ifl,nwf,' Q(0) :') + call dmdspf(tq,1,1,nq,14,ll,nwf) + call basout(ifl,nwf,' corresponding relatives errors') + call dmdspf(tq(mxsol+1),1,1,neqbac,14,ll,nwf) + else if(ifich.eq.53) then + write(buf(1:3),'(i3)') nq + call basout(ifl,nwf,'+++++++++++++++++++++++++++++++++++++++'// + $ '++++++++++++++++++++++++') + Call basout(ifl,nwf,' End of search degree '//buf(1:3)// + $ ' minima ') + call basout(ifl,nwf,'+++++++++++++++++++++++++++++++++++++++'// + $ '++++++++++++++++++++++++') + mxsol=tout + call basout(ifl,nwf,' corresponding denominators:') + call dmdspf(tq,mxsol,neqbac,nq,14,ll,nwf) + call basout(ifl,nwf,' relatives errors') + call dmdspf(tq(mxsol*nq+1),mxsol,neqbac,1,14,ll,nwf) + endif + return +c + 300 continue +c messages de roogp + if(ifich.eq.60) then + call basout(ifl,nwf,'Rootgp : No value found for Beta when '// + & 'looking for intersection with a complex facet') + call basout(ifl,nwf,' Stop') + endif + return +c + 350 continue +c messages de onface + if(ifich.eq.70) then + write(buf(1:3),'(i2)') nq + call basout(ifl,nwf,'Domain boundary reached, ') + call basout(ifl,nwf,'Order is deacreased by'//buf(1:3)) + else if(ifich.eq.71) then + call basout(ifl,nwf,'Remainder:') + call dmdspf(tq,1,1,nq,14,ll,nwf) + endif + return +c + 400 continue + if(ifich.eq.80) then + call basout(ifl,nwf,'Already reached minimum ') + else if(ifich.eq.81) then + call basout(ifl,nwf,'Preserve minimun in tback ') + endif + return + end diff --git a/modules/cacsd/src/fortran/outl2.lo b/modules/cacsd/src/fortran/outl2.lo new file mode 100755 index 000000000..54dad7b4b --- /dev/null +++ b/modules/cacsd/src/fortran/outl2.lo @@ -0,0 +1,12 @@ +# src/fortran/outl2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/outl2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/phi.f b/modules/cacsd/src/fortran/phi.f new file mode 100755 index 000000000..de9913e7f --- /dev/null +++ b/modules/cacsd/src/fortran/phi.f @@ -0,0 +1,40 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + double precision function phi(tq,nq,tg,ng,w) +C%but +C calcule la fonction phi +c%liste d'appel +c Entree : +c tg . tableau des coefficients de la fonction g . +c ng . degre du polynome g +c tq . tableau des coefficients du polynome q +c nq . degre du polynome q +c w . tableau de travail de taille nq+ng+1 +c Sortie : +c phi +c% + + implicit double precision (a-h,o-y) + + dimension tq(nq+1),tg(ng+1),w(nq+ng+1) +c + ltr=1 + lfree=ltr+nq+ng+1 + call lq(nq,tq,w(ltr),tg,ng) +C + ltlq=ltr + call calsca(nq,tq,w(ltlq),y0,tg,ng) +C + phi = 1.0d+0 - y0 +C + return + end + + diff --git a/modules/cacsd/src/fortran/phi.lo b/modules/cacsd/src/fortran/phi.lo new file mode 100755 index 000000000..1cc6053a3 --- /dev/null +++ b/modules/cacsd/src/fortran/phi.lo @@ -0,0 +1,12 @@ +# src/fortran/phi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/phi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/qhesz.f b/modules/cacsd/src/fortran/qhesz.f new file mode 100755 index 000000000..ee6c8fe69 --- /dev/null +++ b/modules/cacsd/src/fortran/qhesz.f @@ -0,0 +1,237 @@ + subroutine qhesz(nm,n,a,b,matq,q,matz,z) +c + integer i,j,k,l,n,lb,l1,nm,nk1,nm1,nm2 + double precision a(nm,n),b(nm,n),z(nm,n),q(nm,n) + double precision r,s,t,u1,u2,v1,v2,rho + logical matz,matq +c +c! purpose +c this subroutine accepts a pair of real general matrices and +c reduces one of them to upper hessenberg form and the other +c to upper triangular form using orthogonal transformations. +c it is usually followed by qzit, qzval and, possibly, qzvec. +c +c! calling sequence +c +c subroutine qhesz(nm,n,a,b,matq,q,matz,z) +c +c on input: +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement; +c +c n is the order of the matrices; +c +c a contains a real general matrix; +c +c b contains a real general matrix; +c +c matz should be set to .true. if the right hand transformations +c are to be accumulated for later use in computing +c eigenvectors, and to .false. otherwise. +c +c on output: +c +c a has been reduced to upper hessenberg form. the elements +c below the first subdiagonal have been set to zero; +c +c b has been reduced to upper triangular form. the elements +c below the main diagonal have been set to zero; +c +c z contains the product of the right hand transformations if +c matz has been set to .true. otherwise, z is not referenced. +c +c! originator +c +c this subroutine is the first step of the qz algorithm +c for solving generalized matrix eigenvalue problems, +c siam j. numer. anal. 10, 241-256(1973) by moler and stewart. +c (modification de la routine qzhes de eispack pour avoir +c la matrice unitaire de changement de base sur les lignes +c donne par la matrice q .memes conventions que pour z.) +c f.d. +c! +c questions and comments should be directed to b. s. garbow, +c applied mathematics division, argonne national laboratory +c +c ------------------------------------------------------------------ +c +c :::::::::: initialize z :::::::::: + if (.not. matz) go to 10 +c + do 3 i = 1, n +c + do 2 j = 1, n + z(i,j) = 0.0d+0 + 2 continue +c + z(i,i) = 1.0d+0 + 3 continue + 10 continue + if(.not.matq) goto 11 + do 31 i=1,n + do 21 j=1,n + q(i,j)=0.0d+0 + 21 continue + q(i,i)=1.0d+0 + 31 continue + 11 continue +c :::::::::: reduce b to upper triangular form :::::::::: + if (n .le. 1) go to 170 + nm1 = n - 1 +c + do 100 l = 1, nm1 + l1 = l + 1 + s = 0.0d+0 +c + do 20 i = l1, n + s = s + abs(b(i,l)) + 20 continue +c + if (s .eq. 0.0d+0) go to 100 + s = s + abs(b(l,l)) + r = 0.0d+0 +c + do 25 i = l, n + b(i,l) = b(i,l) / s + r = r + b(i,l)**2 + 25 continue +c + r = sign(sqrt(r),b(l,l)) + b(l,l) = b(l,l) + r + rho = r * b(l,l) +c + do 50 j = l1, n + t = 0.0d+0 +c + do 30 i = l, n + t = t + b(i,l) * b(i,j) + 30 continue +c + t = -t / rho +c + do 40 i = l, n + b(i,j) = b(i,j) + t * b(i,l) + 40 continue +c + 50 continue +c + do 80 j = 1, n + t = 0.0d+0 +c + do 60 i = l, n + t = t + b(i,l) * a(i,j) + 60 continue +c + t = -t / rho +c + do 70 i = l, n + a(i,j) = a(i,j) + t * b(i,l) + 70 continue +c + 80 continue + if(.not.matq) goto 99 + do 780 j = 1, n + t = 0.0d+0 +c + do 760 i = l, n + t = t + b(i,l) * q(i,j) + 760 continue +c + t = -t / rho +c + do 770 i = l, n + q(i,j)=q(i,j)+t*b(i,l) + 770 continue +c + 780 continue + 99 continue +c + b(l,l) = -s * r +c + do 90 i = l1, n + b(i,l) = 0.0d+0 + 90 continue +c + 100 continue +c :::::::::: reduce a to upper hessenberg form, while +c keeping b triangular :::::::::: + if (n .eq. 2) go to 170 + nm2 = n - 2 +c + do 160 k = 1, nm2 + nk1 = nm1 - k +c :::::::::: for l=n-1 step -1 until k+1 do -- :::::::::: + do 150 lb = 1, nk1 + l = n - lb + l1 = l + 1 +c :::::::::: zero a(l+1,k) :::::::::: + s = abs(a(l,k)) + abs(a(l1,k)) + if (s .eq. 0.0d+0) go to 150 + u1 = a(l,k) / s + u2 = a(l1,k) / s + r = sign(sqrt(u1*u1+u2*u2),u1) + v1 = -(u1 + r) / r + v2 = -u2 / r + u2 = v2 / v1 +c + do 110 j = k, n + t = a(l,j) + u2 * a(l1,j) + a(l,j) = a(l,j) + t * v1 + a(l1,j) = a(l1,j) + t * v2 + 110 continue +c + a(l1,k) = 0.0d+0 +c + do 120 j = l, n + t = b(l,j) + u2 * b(l1,j) + b(l,j) = b(l,j) + t * v1 + b(l1,j) = b(l1,j) + t * v2 + 120 continue + if(.not.matq) goto 122 + do 121 j=1,n + t=q(l,j)+u2*q(l1,j) + q(l,j)=q(l,j)+t*v1 + q(l1,j)=q(l1,j)+t*v2 + 121 continue + 122 continue +c :::::::::: zero b(l+1,l) :::::::::: + s = abs(b(l1,l1)) + abs(b(l1,l)) + if (s .eq. 0.0d+0) go to 150 + u1 = b(l1,l1) / s + u2 = b(l1,l) / s + r = sign(sqrt(u1*u1+u2*u2),u1) + v1 = -(u1 + r) / r + v2 = -u2 / r + u2 = v2 / v1 +c + do 130 i = 1, l1 + t = b(i,l1) + u2 * b(i,l) + b(i,l1) = b(i,l1) + t * v1 + b(i,l) = b(i,l) + t * v2 + 130 continue +c + b(l1,l) = 0.0d+0 +c + do 140 i = 1, n + t = a(i,l1) + u2 * a(i,l) + a(i,l1) = a(i,l1) + t * v1 + a(i,l) = a(i,l) + t * v2 + 140 continue +c + if (.not. matz) go to 150 +c + do 145 i = 1, n + t = z(i,l1) + u2 * z(i,l) + z(i,l1) = z(i,l1) + t * v1 + z(i,l) = z(i,l) + t * v2 + 145 continue +c + 150 continue +c + 160 continue +c + 170 return +c :::::::::: last card of qzhes :::::::::: + end diff --git a/modules/cacsd/src/fortran/qhesz.lo b/modules/cacsd/src/fortran/qhesz.lo new file mode 100755 index 000000000..7bae5e851 --- /dev/null +++ b/modules/cacsd/src/fortran/qhesz.lo @@ -0,0 +1,12 @@ +# src/fortran/qhesz.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/qhesz.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/qitz.f b/modules/cacsd/src/fortran/qitz.f new file mode 100755 index 000000000..977d4d2eb --- /dev/null +++ b/modules/cacsd/src/fortran/qitz.f @@ -0,0 +1,408 @@ + subroutine qitz(nm,n,a,b,eps1,matq,q,matz,z,ierr) +c + integer i,j,k,l,n,en,k1,k2,ld,ll,l1,na,nm,ish,itn,its,km1,lm1, + x enm2,ierr,lor1,enorn + double precision a(nm,n),b(nm,n),z(nm,n),q(nm,n) + double precision r,s,t,a1,a2,a3,ep,sh,u1,u2,u3,v1,v2,v3,ani, + x a11,a12,a21,a22,a33,a34,a43,a44,bni,b11,b12,b22,b33,b34, + x b44,epsa,epsb,eps1,anorm,bnorm,dlamch + logical matz,matq,notlas +c +c +c this subroutine is the second step of the qz algorithm +c for solving generalized matrix eigenvalue problems, +c siam j. numer. anal. 10, 241-256(1973) by moler and stewart, +c as modified in technical note nasa tn d-7305(1973) by ward. +c +c! purpose +c this subroutine accepts a pair of real matrices, one of them +c in upper hessenberg form and the other in upper triangular form. +c it reduces the hessenberg matrix to quasi-triangular form using +c orthogonal transformations while maintaining the triangular form +c of the other matrix. it is usually preceded by qhesz and +c followed by qvalz and, possibly, qvecz. +c +c MODIFIED FROM EISPACK ROUTINE ``QZIT'' TO ALSO RETURN THE Q +c MATRIX. +c +c! calling sequence +c subroutine qitz(nm,n,a,b,eps1,matq,q,matz,z,ierr) +c double precision a(nm,n),b(nm,n),z(nm,n),q(nm,n),eps1 +c logical matz,matq +c integer nm,n,ierr +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement; +c +c n is the order of the matrices; +c +c a contains a real upper hessenberg matrix; +c +c b contains a real upper triangular matrix; +c +c eps1 is a tolerance used to determine negligible elements. +c eps1 = 0.0 (or negative) may be input, in which case an +c element will be neglected only if it is less than roundoff +c error times the norm of its matrix. if the input eps1 is +c positive, then an element will be considered negligible +c if it is less than eps1 times the norm of its matrix. a +c positive value of eps1 may result in faster execution, +c but less accurate results; +c en sortie eps1 vaut eps1*(norme de b),utilise par qzval +c et qzvec +c +c matz should be set to .true. if the right hand transformations +c are to be accumulated for later use in computing +c eigenvectors, and to .false. otherwise; +c +c z contains, if matz has been set to .true., the +c transformation matrix produced in the reduction +c by qzhes, if performed, or else the identity matrix. +c if matz has been set to .false., z is not referenced. +c +c matq should be set to .true. if left hand transformation is +c required, and to .false. otherwise +c +c q contains, if the left hand transformation is required, +c the transformation matrix produced by qhesz. +c +c on output: +c +c a has been reduced to quasi-triangular form. the elements +c below the first subdiagonal are still zero and no two +c consecutive subdiagonal elements are nonzero; +c +c b is still in upper triangular form, although its elements +c have been altered. +c +c z contains the product of the right hand transformations +c (for both steps) if matz has been set to .true.; +c +c q contains the product of the right hand transformation with +c initial q +c +c ierr is set to +c zero for normal return, +c j if neither a(j,j-1) nor a(j-1,j-2) has become +c zero after 30*n iterations. +c +c! originator +c +c F Delebecque INRIA +c +c This subroutine is a modification of qzit (eispack). +c Modifications concern computation of the left vector space q, and +c treatment of upper left 2 x 2 block of a to make sure it is really +c in relation with complex eigenvalues. +c +c this version dated august 1983. +cc! +c + ierr = 0 +c :::::::::: compute epsa,epsb :::::::::: + anorm = 0.0d+0 + bnorm = 0.0d+0 +c + do 30 i = 1, n + ani = 0.0d+0 + if (i .ne. 1) ani = abs(a(i,i-1)) + bni = 0.0d+0 +c + do 20 j = i, n + ani = ani + abs(a(i,j)) + bni = bni + abs(b(i,j)) + 20 continue +c + if (ani .gt. anorm) anorm = ani + if (bni .gt. bnorm) bnorm = bni + 30 continue +c + if (anorm .eq. 0.0d+0) anorm = 1.0d+0 + if (bnorm .eq. 0.0d+0) bnorm = 1.0d+0 + ep = eps1 + if (ep .gt. 0.0d0) go to 50 +c .......... use roundoff level if eps1 is zero .......... + ep = dlamch('p') + 50 epsa = ep * anorm + epsb = ep * bnorm +c :::::::::: reduce a to quasi-triangular form, while +c keeping b triangular :::::::::: + lor1 = 1 + enorn = n + en = n + itn = 30*n +c :::::::::: begin qz step :::::::::: + 60 if (en .le. 1) go to 1001 + if (.not. matz) enorn = en + its = 0 + na = en - 1 + enm2 = na - 1 + 70 ish = 2 +c :::::::::: check for convergence or reducibility. +c for l=en step -1 until 1 do -- :::::::::: + do 80 ll = 1, en + lm1 = en - ll + l = lm1 + 1 + if (l .eq. 1) go to 95 + if (abs(a(l,lm1)) .le. epsa) go to 90 + 80 continue +c + 90 a(l,lm1) = 0.0d+0 + if (l .lt. na) go to 95 +c :::::::::: 1-by-1 or 2-by-2 block isolated :::::::::: + en = lm1 + go to 60 +c :::::::::: check for small top of b :::::::::: + 95 ld = l + 100 l1 = l + 1 + b11 = b(l,l) + if (abs(b11) .gt. epsb) go to 120 + b(l,l) = 0.0d+0 + s = abs(a(l,l)) + abs(a(l1,l)) + u1 = a(l,l) / s + u2 = a(l1,l) / s + r = sign(sqrt(u1*u1+u2*u2),u1) + v1 = -(u1 + r) / r + v2 = -u2 / r + u2 = v2 / v1 +c + do 110 j = l, enorn + t = a(l,j) + u2 * a(l1,j) + a(l,j) = a(l,j) + t * v1 + a(l1,j) = a(l1,j) + t * v2 + t = b(l,j) + u2 * b(l1,j) + b(l,j) = b(l,j) + t * v1 + b(l1,j) = b(l1,j) + t * v2 + 110 continue + if(.not.matq) goto 111 + do 112 j=1,n + t=q(l,j)+u2*q(l1,j) + q(l,j)=q(l,j)+t*v1 + q(l1,j)=q(l1,j)+t*v2 + 112 continue + + 111 continue +c + if (l .ne. 1) a(l,lm1) = -a(l,lm1) + lm1 = l + l = l1 + go to 90 + 120 a11 = a(l,l) / b11 + a21 = a(l1,l) / b11 + if (ish .eq. 1) go to 140 +c :::::::::: iteration strategy :::::::::: + if (itn .eq. 0) go to 1000 + if (its .eq. 10) go to 155 +c :::::::::: determine type of shift :::::::::: + b22 = b(l1,l1) + if (abs(b22) .lt. epsb) b22 = epsb + b33 = b(na,na) + if (abs(b33) .lt. epsb) b33 = epsb + b44 = b(en,en) + if (abs(b44) .lt. epsb) b44 = epsb + a33 = a(na,na) / b33 + a34 = a(na,en) / b44 + a43 = a(en,na) / b33 + a44 = a(en,en) / b44 + b34 = b(na,en) / b44 + t = 0.50d+0 * (a43 * b34 - a33 - a44) + r = t * t + a34 * a43 - a33 * a44 + if (r .lt. 0.0d+0) go to 150 +c :::::::::: determine single shift zeroth column of a :::::::::: + ish = 1 + r = sqrt(r) + sh = -t + r + s = -t - r + if (abs(s-a44) .lt. abs(sh-a44)) sh = s +c if(enm2.le.0) goto 140 +c :::::::::: look for two consecutive small +c sub-diagonal elements of a. +c for l=en-2 step -1 until ld do -- :::::::::: + do 130 ll = ld, enm2 + l = enm2 + ld - ll + if (l .eq. ld) go to 140 + lm1 = l - 1 + l1 = l + 1 + t = a(l,l) + if (abs(b(l,l)) .gt. epsb) t = t - sh * b(l,l) + if (abs(a(l,lm1)) .le. abs(t/a(l1,l)) * epsa) go to 100 + 130 continue +c + 140 a1 = a11 - sh + a2 = a21 + if (l .ne. ld) a(l,lm1) = -a(l,lm1) + go to 160 +c :::::::::: determine double shift zeroth column of a :::::::::: + 150 if (en .le. 2) go to 1001 + a12 = a(l,l1) / b22 + a22 = a(l1,l1) / b22 + b12 = b(l,l1) / b22 + a1 = ((a33 - a11) * (a44 - a11) - a34 * a43 + a43 * b34 * a11) + x / a21 + a12 - a11 * b12 + a2 = (a22 - a11) - a21 * b12 - (a33 - a11) - (a44 - a11) + x + a43 * b34 + a3 = a(l1+1,l1) / b22 + go to 160 +c :::::::::: ad hoc shift :::::::::: + 155 a1 = 0.0d+0 + a2 = 1.0d+0 + a3 = 1.16050d+0 + 160 its = its + 1 + itn = itn - 1 + if (.not. matz) lor1 = ld +c :::::::::: main loop :::::::::: + do 260 k = l, na + notlas = k .ne. na .and. ish .eq. 2 + k1 = k + 1 + k2 = k + 2 + km1 = max(k-1,l) + ll = min(en,k1+ish) + if (notlas) go to 190 +c :::::::::: zero a(k+1,k-1) :::::::::: + if (k .eq. l) go to 170 + a1 = a(k,km1) + a2 = a(k1,km1) + 170 s = abs(a1) + abs(a2) + if (s .eq. 0.0d+0) go to 70 + u1 = a1 / s + u2 = a2 / s + r = sign(sqrt(u1*u1+u2*u2),u1) + v1 = -(u1 + r) / r + v2 = -u2 / r + u2 = v2 / v1 +c + do 180 j = km1, enorn + t = a(k,j) + u2 * a(k1,j) + a(k,j) = a(k,j) + t * v1 + a(k1,j) = a(k1,j) + t * v2 + t = b(k,j) + u2 * b(k1,j) + b(k,j) = b(k,j) + t * v1 + b(k1,j) = b(k1,j) + t * v2 + 180 continue + + if(.not.matq) goto 181 + do 182 j=1,n + t=q(k,j)+u2*q(k1,j) + q(k,j)=q(k,j)+t*v1 + q(k1,j)=q(k1,j)+t*v2 + 182 continue + + 181 continue +c + if (k .ne. l) a(k1,km1) = 0.0d+0 + go to 240 +c :::::::::: zero a(k+1,k-1) and a(k+2,k-1) :::::::::: + 190 if (k .eq. l) go to 200 + a1 = a(k,km1) + a2 = a(k1,km1) + a3 = a(k2,km1) + 200 s = abs(a1) + abs(a2) + abs(a3) + if (s .eq. 0.0d+0) go to 260 + u1 = a1 / s + u2 = a2 / s + u3 = a3 / s + r = sign(sqrt(u1*u1+u2*u2+u3*u3),u1) + v1 = -(u1 + r) / r + v2 = -u2 / r + v3 = -u3 / r + u2 = v2 / v1 + u3 = v3 / v1 +c + do 210 j = km1, enorn + t = a(k,j) + u2 * a(k1,j) + u3 * a(k2,j) + a(k,j) = a(k,j) + t * v1 + a(k1,j) = a(k1,j) + t * v2 + a(k2,j) = a(k2,j) + t * v3 + t = b(k,j) + u2 * b(k1,j) + u3 * b(k2,j) + b(k,j) = b(k,j) + t * v1 + b(k1,j) = b(k1,j) + t * v2 + b(k2,j) = b(k2,j) + t * v3 + 210 continue + + if(.not.matq) goto 211 + do 212 j=1,n + t=q(k,j)+u2*q(k1,j)+u3*q(k2,j) + q(k,j)=q(k,j)+t*v1 + q(k1,j)=q(k1,j)+t*v2 + q(k2,j)=q(k2,j)+t*v3 + 212 continue + + 211 continue +c + if (k .eq. l) go to 220 + a(k1,km1) = 0.0d+0 + a(k2,km1) = 0.0d+0 +c :::::::::: zero b(k+2,k+1) and b(k+2,k) :::::::::: + 220 s = abs(b(k2,k2)) + abs(b(k2,k1)) + abs(b(k2,k)) + if (s .eq. 0.0d+0) go to 240 + u1 = b(k2,k2) / s + u2 = b(k2,k1) / s + u3 = b(k2,k) / s + r = sign(sqrt(u1*u1+u2*u2+u3*u3),u1) + v1 = -(u1 + r) / r + v2 = -u2 / r + v3 = -u3 / r + u2 = v2 / v1 + u3 = v3 / v1 +c + do 230 i = lor1, ll + t = a(i,k2) + u2 * a(i,k1) + u3 * a(i,k) + a(i,k2) = a(i,k2) + t * v1 + a(i,k1) = a(i,k1) + t * v2 + a(i,k) = a(i,k) + t * v3 + t = b(i,k2) + u2 * b(i,k1) + u3 * b(i,k) + b(i,k2) = b(i,k2) + t * v1 + b(i,k1) = b(i,k1) + t * v2 + b(i,k) = b(i,k) + t * v3 + 230 continue +c + b(k2,k) = 0.0d+0 + b(k2,k1) = 0.0d+0 + if (.not. matz) go to 240 +c + do 235 i = 1, n + t = z(i,k2) + u2 * z(i,k1) + u3 * z(i,k) + z(i,k2) = z(i,k2) + t * v1 + z(i,k1) = z(i,k1) + t * v2 + z(i,k) = z(i,k) + t * v3 + 235 continue +c :::::::::: zero b(k+1,k) :::::::::: + 240 s = abs(b(k1,k1)) + abs(b(k1,k)) + if (s .eq. 0.0d+0) go to 260 + u1 = b(k1,k1) / s + u2 = b(k1,k) / s + r = sign(sqrt(u1*u1+u2*u2),u1) + v1 = -(u1 + r) / r + v2 = -u2 / r + u2 = v2 / v1 +c + do 250 i = lor1, ll + t = a(i,k1) + u2 * a(i,k) + a(i,k1) = a(i,k1) + t * v1 + a(i,k) = a(i,k) + t * v2 + t = b(i,k1) + u2 * b(i,k) + b(i,k1) = b(i,k1) + t * v1 + b(i,k) = b(i,k) + t * v2 + 250 continue +c + b(k1,k) = 0.0d+0 + if (.not. matz) go to 260 +c + do 255 i = 1, n + t = z(i,k1) + u2 * z(i,k) + z(i,k1) = z(i,k1) + t * v1 + z(i,k) = z(i,k) + t * v2 + 255 continue +c + 260 continue +c :::::::::: end qz step :::::::::: + go to 70 +c :::::::::: set error -- neither bottom subdiagonal element +c has become negligible after 50 iterations :::::::::: + 1000 ierr = en +c :::::::::: save epsb for use by qzval and qzvec :::::::::: + 1001 if (n .gt. 1) eps1 = epsb + return +c :::::::::: last card of qzit :::::::::: + end diff --git a/modules/cacsd/src/fortran/qitz.lo b/modules/cacsd/src/fortran/qitz.lo new file mode 100755 index 000000000..b9c80f3d1 --- /dev/null +++ b/modules/cacsd/src/fortran/qitz.lo @@ -0,0 +1,12 @@ +# src/fortran/qitz.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/qitz.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/qvalz.f b/modules/cacsd/src/fortran/qvalz.f new file mode 100755 index 000000000..2acfe9cc6 --- /dev/null +++ b/modules/cacsd/src/fortran/qvalz.f @@ -0,0 +1,304 @@ +C/MEMBR ADD NAME=QVALZ,SSI=0 + subroutine qvalz(nm,n,a,b,epsb,alfr,alfi,beta,matq,q,matz,z) +c + integer i,j,n,en,na,nm,nn,isw + double precision a(nm,n),b(nm,n),alfr(n),alfi(n),beta(n) + double precision z(nm,n),q(nm,n) + double precision c,d,e,r,s,t,an,a1,a2,bn,cq,cz,di,dr,ei,ti,tr + double precision u1,u2,v1,v2,a1i,a11,a12,a2i,a21,a22 + double precision b11,b12,b22,sqi,sqr + double precision ssi,ssr,szi,szr,a11i,a11r,a12i,a12r,a22i,a22r + double precision epsb + logical matz,matq +c +c! purpose +c this subroutine accepts a pair of real matrices, one of them +c in quasi-triangular form and the other in upper triangular form. +c it reduces the quasi-triangular matrix further, so that any +c remaining 2-by-2 blocks correspond to pairs of complex +c eigenvalues, and returns quantities whose ratios give the +c generalized eigenvalues. it is usually preceded by qzhes +c and qzit and may be followed by qzvec. +c +c MODIFIED FROM EISPACK ROUTINE ``QZVAL'' TO ALSO RETURN THE Q +c MATRIX. IN ADDITION, THE TOLERANCE epsb IS DIRECTLY PASSED IN +c THE CALLING LIST INSTEAD OF VIA b(n,1) +c +c! calling sequence +c +c subroutine qvalz(nm,n,a,b,epsb,alfr,alfi,beta,matq,q,matz,z) +c on input: +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement; +c +c n is the order of the matrices; +c +c a contains a real upper quasi-triangular matrix; +c +c b contains a real upper triangular matrix. +c +c epsb: tolerance computed and saved in qitz (qzit) +c +c matz (resp matq) should be set to .true. if the right +c (resp left) hand transformations are to be accumulated +c for later use in computing eigenvectors, and to .false. +c otherwise; +c +c z (resp q) contains, if matz (resp matq) has been set +c to .true., the transformation matrix produced in the +c reductions by qzhes and qzit, if performed, or else the +c identity matrix. if matz has been set to .false., z is not +c referenced. +c +c on output: +c +c a has been reduced further to a quasi-triangular matrix +c in which all nonzero subdiagonal elements correspond to +c pairs of complex eigenvalues; +c +c b is still in upper triangular form, although its elements +c have been altered. b(n,1) is unaltered; +c +c alfr and alfi contain the real and imaginary parts of the +c diagonal elements of the triangular matrix that would be +c obtained if a were reduced completely to triangular form +c by unitary transformations. non-zero values of alfi occur +c in pairs, the first member positive and the second negative; +c +c beta contains the diagonal elements of the corresponding b, +c normalized to be real and non-negative. the generalized +c eigenvalues are then the ratios ((alfr+i*alfi)/beta); +c +c z (resp q) contains the product of the right resp left hand +c (for all three steps) if matz (resp, matq) has been set +c to .true. +c +c! originator +c +c this subroutine is the third step of the qz algorithm +c for solving generalized matrix eigenvalue problems, +c siam j. numer. anal. 10, 241-256(1973) by moler and stewart. +c modification de la routine qzval de eispack pour avoir la matrice +c q en option +c! +c questions and comments should be directed to b. s. garbow, +c applied mathematics division, argonne national laboratory +c +c ------------------------------------------------------------------ +c + isw = 1 +c :::::::::: find eigenvalues of quasi-triangular matrices. +c for en=n step -1 until 1 do -- :::::::::: + do 510 nn = 1, n + en = n + 1 - nn + na = en - 1 + if (isw .eq. 2) go to 505 + if (en .eq. 1) go to 410 + if (a(en,na) .ne. 0.0d+0) go to 420 +c :::::::::: 1-by-1 block, one real root :::::::::: + 410 alfr(en) = a(en,en) + if (b(en,en) .lt. 0.0d+0) alfr(en) = -alfr(en) + beta(en) = abs(b(en,en)) + alfi(en) = 0.0d+0 + go to 510 +c :::::::::: 2-by-2 block :::::::::: + 420 if (abs(b(na,na)) .le. epsb) go to 455 + if (abs(b(en,en)) .gt. epsb) go to 430 + a1 = a(en,en) + a2 = a(en,na) + bn = 0.0d+0 + go to 435 + 430 an = abs(a(na,na)) + abs(a(na,en)) + abs(a(en,na)) + & + abs(a(en,en)) + bn = abs(b(na,na)) + abs(b(na,en)) + abs(b(en,en)) + a11 = a(na,na) / an + a12 = a(na,en) / an + a21 = a(en,na) / an + a22 = a(en,en) / an + b11 = b(na,na) / bn + b12 = b(na,en) / bn + b22 = b(en,en) / bn + e = a11 / b11 + ei = a22 / b22 + s = a21 / (b11 * b22) + t = (a22 - e * b22) / b22 + if (abs(e) .le. abs(ei)) go to 431 + e = ei + t = (a11 - e * b11) / b11 + 431 c = 0.50d+0 * (t - s * b12) + d = c * c + s * (a12 - e * b12) + if (d .lt. 0.0d+0) go to 480 +c :::::::::: two real roots. +c zero both a(en,na) and b(en,na) :::::::::: + e = e + (c + sign(sqrt(d),c)) + a11 = a11 - e * b11 + a12 = a12 - e * b12 + a22 = a22 - e * b22 + if (abs(a11) + abs(a12) .lt. + x abs(a21) + abs(a22)) go to 432 + a1 = a12 + a2 = a11 + go to 435 + 432 a1 = a22 + a2 = a21 +c :::::::::: choose and apply real z :::::::::: + 435 s = abs(a1) + abs(a2) + u1 = a1 / s + u2 = a2 / s + r = sign(sqrt(u1*u1+u2*u2),u1) + v1 = -(u1 + r) / r + v2 = -u2 / r + u2 = v2 / v1 +c + do 440 i = 1, en + t = a(i,en) + u2 * a(i,na) + a(i,en) = a(i,en) + t * v1 + a(i,na) = a(i,na) + t * v2 + t = b(i,en) + u2 * b(i,na) + b(i,en) = b(i,en) + t * v1 + b(i,na) = b(i,na) + t * v2 + 440 continue +c + if (.not. matz) go to 450 +c + do 445 i = 1, n + t = z(i,en) + u2 * z(i,na) + z(i,en) = z(i,en) + t * v1 + z(i,na) = z(i,na) + t * v2 + 445 continue +c + 450 if (bn .eq. 0.0d+0) go to 475 + if (an .lt. abs(e) * bn) go to 455 + a1 = b(na,na) + a2 = b(en,na) + go to 460 + 455 a1 = a(na,na) + a2 = a(en,na) +c :::::::::: choose and apply real q :::::::::: + 460 s = abs(a1) + abs(a2) + if (s .eq. 0.0d+0) go to 475 + u1 = a1 / s + u2 = a2 / s + r = sign(sqrt(u1*u1+u2*u2),u1) + v1 = -(u1 + r) / r + v2 = -u2 / r + u2 = v2 / v1 +c + do 470 j = na, n + t = a(na,j) + u2 * a(en,j) + a(na,j) = a(na,j) + t * v1 + a(en,j) = a(en,j) + t * v2 + t = b(na,j) + u2 * b(en,j) + b(na,j) = b(na,j) + t * v1 + b(en,j) = b(en,j) + t * v2 + 470 continue +ccccccccccccccccccccccccccccccccccccccccc +c MODIFIED TO ACCUMULATE Q AS WELL +ccccccccccccccccccccccccccccccccccccccc + if(.not.matq) goto 471 + do 472 j=1,n + t=q(na,j)+u2*q(en,j) + q(na,j)=q(na,j)+t*v1 + q(en,j)=q(en,j)+t*v2 + 472 continue +cccccccccccccccccccccccccccccccccccccccc + 471 continue +c + 475 a(en,na) = 0.0d+0 + b(en,na) = 0.0d+0 + alfr(na) = a(na,na) + alfr(en) = a(en,en) + if (b(na,na) .lt. 0.0d+0) alfr(na) = -alfr(na) + if (b(en,en) .lt. 0.0d+0) alfr(en) = -alfr(en) + beta(na) = abs(b(na,na)) + beta(en) = abs(b(en,en)) + alfi(en) = 0.0d+0 + alfi(na) = 0.0d+0 + go to 505 +c :::::::::: two complex roots :::::::::: + 480 e = e + c + ei = sqrt(-d) + a11r = a11 - e * b11 + a11i = ei * b11 + a12r = a12 - e * b12 + a12i = ei * b12 + a22r = a22 - e * b22 + a22i = ei * b22 + if (abs(a11r) + abs(a11i) + abs(a12r) + abs(a12i) .lt. + x abs(a21) + abs(a22r) + abs(a22i)) go to 482 + a1 = a12r + a1i = a12i + a2 = -a11r + a2i = -a11i + go to 485 + 482 a1 = a22r + a1i = a22i + a2 = -a21 + a2i = 0.0d+0 +c :::::::::: choose complex z :::::::::: + 485 cz = sqrt(a1*a1+a1i*a1i) + if (cz .eq. 0.0d+0) go to 487 + szr = (a1 * a2 + a1i * a2i) / cz + szi = (a1 * a2i - a1i * a2) / cz + r = sqrt(cz*cz+szr*szr+szi*szi) + cz = cz / r + szr = szr / r + szi = szi / r + go to 490 + 487 szr = 1.0d+0 + szi = 0.0d+0 + 490 if (an .lt. (abs(e) + ei) * bn) go to 492 + a1 = cz * b11 + szr * b12 + a1i = szi * b12 + a2 = szr * b22 + a2i = szi * b22 + go to 495 + 492 a1 = cz * a11 + szr * a12 + a1i = szi * a12 + a2 = cz * a21 + szr * a22 + a2i = szi * a22 +c :::::::::: choose complex q :::::::::: + 495 cq = sqrt(a1*a1+a1i*a1i) + if (cq .eq. 0.0d+0) go to 497 + sqr = (a1 * a2 + a1i * a2i) / cq + sqi = (a1 * a2i - a1i * a2) / cq + r = sqrt(cq*cq+sqr*sqr+sqi*sqi) + cq = cq / r + sqr = sqr / r + sqi = sqi / r + go to 500 + 497 sqr = 1.0d+0 + sqi = 0.0d+0 +c :::::::::: compute diagonal elements that would result +c if transformations were applied :::::::::: + 500 ssr = sqr * szr + sqi * szi + ssi = sqr * szi - sqi * szr + i = 1 + tr = cq * cz * a11 + cq * szr * a12 + sqr * cz * a21 + x + ssr * a22 + ti = cq * szi * a12 - sqi * cz * a21 + ssi * a22 + dr = cq * cz * b11 + cq * szr * b12 + ssr * b22 + di = cq * szi * b12 + ssi * b22 + go to 503 + 502 i = 2 + tr = ssr * a11 - sqr * cz * a12 - cq * szr * a21 + x + cq * cz * a22 + ti = -ssi * a11 - sqi * cz * a12 + cq * szi * a21 + dr = ssr * b11 - sqr * cz * b12 + cq * cz * b22 + di = -ssi * b11 - sqi * cz * b12 + 503 t = ti * dr - tr * di + j = na + if (t .lt. 0.0d+0) j = en + r = sqrt(dr*dr+di*di) + beta(j) = bn * r + alfr(j) = an * (tr * dr + ti * di) / r + alfi(j) = an * t / r + if (i .eq. 1) go to 502 + 505 isw = 3 - isw + 510 continue +c + return +c :::::::::: last card of qzval :::::::::: + end diff --git a/modules/cacsd/src/fortran/qvalz.lo b/modules/cacsd/src/fortran/qvalz.lo new file mode 100755 index 000000000..e7a25ec00 --- /dev/null +++ b/modules/cacsd/src/fortran/qvalz.lo @@ -0,0 +1,12 @@ +# src/fortran/qvalz.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/qvalz.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/ricd.f b/modules/cacsd/src/fortran/ricd.f new file mode 100755 index 000000000..8c9ce5ca2 --- /dev/null +++ b/modules/cacsd/src/fortran/ricd.f @@ -0,0 +1,210 @@ +C/MEMBR ADD NAME=RICD,SSI=0 + subroutine ricd(nf,nn,f,n,h,g,cond,x,z,nz,w,eps,ipvt,wrk1,wrk2, + & ierr) +C!purpose +C this subroutine solves the discrete-time algebraic matrix +C riccati equation +C +C t t t -1 t +C x = f *x*f - f *x*g1*((g2 + g1 *x*g1) )*g1 *x*f + h +C +C by laub's variant of the hamiltonian-eigenvector approach. +C +C!method +C laub, a.j., a schur method for solving algebraic riccati +C equations, ieee trans. aut. contr., ac-24(1979), 913-921. +C +C the matrix f is assumed to be nonsingular and the matrices g1 and +C g2 are assumed to be combined into the square array g as follows: +C -1 t +C g = g1*g2 *g1 +C +C in case f is singular, see: pappas, t., a.j. laub, and n.r. +C sandell, on the numerical solution of the discrete-time +C algebraic riccati equation, ieee trans. aut. contr., ac-25(1980 +C 631-641. +C +C!calling sequence +C subroutine ricd (nf,nn,f,n,h,g,cond,x,z,nz,w,eps +C + ipvt,wrk1,wrk2,ierr ) +C +C integer nf,ng,nh,nz,n,nn,itype(nn),ipvt(n),ierr +C double precision f(nf,n),g(ng,n),h(nh,n),z(nz,nn),w(nz,nn), +C + ,wrk1(nn),wrk2(nn),x(nf,n) +C on input: +C nf,nz row dimensions of the arrays containing +C (f,g,h) and (z,w), respectively, as +C declared in the calling program dimension +C statement; +C +C n order of the matrices f,g,h; +C +C nn = 2*n = order of the internally generated +C matrices z and w; +C +C f a nonsingular n x n (real) matrix; +C +C g,h n x n symmetric, nonnegative definite +C (real) matrices. +C +C eps relative machine precision +C +C +C on output: +C +C x n x n array containing txe unique positive +C (or nonnegative) definite solution of the +C riccati equation; +C +C +C z,w 2*n x 2*n real scratch arrays used for +C computations involving the symplectic +C matrix associated with the riccati equation; +C +C wrk1,wrk2 real scratch vectors of lengths 2*n +C +C cond +C condition number estimate for the final nth +C order linear matrix equation solved; +C +C ipvt integer scratch vector of length 2*n +C +C ierr error code +C ierr=0 : ok +C ierr=-1 : singular linear system +C ierr=i : i th eigenvalue is badly calculated +C +C ***note: all scratch arrays must be declared and included +C in the call.*** +C +C!comments +C it is assumed that: +C (1) f is nonsingular (can be relaxed; see ref. above ) +C (2) g and h are nonnegative definite +C (3) (f,g1) is stabilizable and (c,f) is detectable where +C t +C c *c = h (c of full rank = rank(h)). +C under these assumptions the solution (returned in the array h) is +C unique and nonnegative definite. +C +C!originator +C written by alan j. laub (dep't. of elec. engrg. - systems, univ. +C of southern calif., los angeles, ca 90007; ph.: (213) 743-5535), +C sep. 1977. +C most recent version: apr. 15, 1981. +C +C!auxiliary routines +C hqror2,inva,fout,mulwoa,mulwob +C dgeco,dgesl (linpack ) +C balanc,balbak,orthes,ortran (eispack ) +C ddot (blas) +C! +C +C *****parameters: + integer nf,nz,n,nn,ipvt(nn),ierr + double precision f(nf,n),g(nf,n),h(nf,n),z(nz,nn),w(nz,nn), + & wrk1(nn),wrk2(nn),x(nf,n) + logical fail + integer fout + external fout +C +C *****local variables: + integer i,j,low,igh,nlow,npi,npj,nup + double precision eps,t(1),cond,det(2),ddot +C +C +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C +C eps is a machine dependent parameter +C specifying the relative precision of realing point arithmetic. +C for example, eps = 16.0d+0**(-13) for double precision arithmetic +C on ibm s360/s370. +C +C +C ( f**-1 (f**-1)*g ) +C set up symplectic matrix z=( ) +C ( h*(f**-1) h*(f**-1)*g+trans(f) ) +C +C z11=f**-1 + fail = .false. + do 20 j = 1,n + do 10 i = 1,n + z(i,j) = f(i,j) + 10 continue + 20 continue + call dgeco(z,nz,n,ipvt,cond,wrk1) + if ((cond+1.0d+0) .le. 1.0d+0) goto 200 + call dgedi(z,nz,n,ipvt,det,wrk1,1) +C z21=h*f**-1; z12=(f**-1)*g + do 90 j = 1,n + npj = n + j + do 90 i = 1,n + npi = n + i + z(i,npj) = ddot(n,z(i,1),nz,g(1,j),1) + z(npi,j) = ddot(n,h(i,1),nf,z(1,j),1) + 90 continue +C z22=transp(f)+h*(f**-1)*g + do 140 j = 1,n + npj = n + j + do 130 i = 1,n + npi = n + i + z(npi,npj) = f(j,i) + ddot(n,z(npi,1),nz,g(1,j),1) + 130 continue + 140 continue +C +C balance z +C + call balanc(nz,nn,z,low,igh,wrk1) +C +C reduce z to real schur form with eigenvalues outside the unit +C disk in the upper left n x n upper quasi-triangular block +C + nlow = 1 + nup = nn + call orthes(nz,nn,nlow,nup,z,wrk2) + call ortran(nz,nn,nlow,nup,z,wrk2,w) + call hqror2(nz,nn,1,nn,z,t,t,w,ierr,11) + if (ierr .ne. 0) goto 210 + call inva(nz,nn,z,w,fout,eps,ndim,fail,ipvt) + if (fail) goto 220 + if (ndim .ne. n) goto 230 +C +C compute solution of the riccati equation from the orthogonal +C matrix now in the array w. store the result in the array h. +C + call balbak(nz,nn,low,igh,wrk1,nn,w) +C resolution systeme lineaire + call dgeco(w,nz,n,ipvt,cond,wrk1) + if (cond+1.0d+0 .le. 1.0d+0) goto 200 + do 160 j = 1,n + npj = n + j + do 150 i = 1,n + x(i,j) = w(npj,i) + 150 continue + 160 continue + do 165 i = 1,n + 165 call dgesl(w,nz,n,ipvt,x(1,i),1) + return + 200 continue +C systeme lineaire numeriquement singulier + ierr = -1 + return + 210 continue +C erreur dans hqror2 + ierr = i + return +C + 220 continue +C erreur dans inva + return +C + 230 continue +C la matrice symplectique n'a pas le +C bon nombre de val. propres de module +C inferieur a 1. + return +C +C last line of ricd +C + end + diff --git a/modules/cacsd/src/fortran/ricd.lo b/modules/cacsd/src/fortran/ricd.lo new file mode 100755 index 000000000..5585f18d3 --- /dev/null +++ b/modules/cacsd/src/fortran/ricd.lo @@ -0,0 +1,12 @@ +# src/fortran/ricd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ricd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/rilac.f b/modules/cacsd/src/fortran/rilac.f new file mode 100755 index 000000000..1f63bf9c9 --- /dev/null +++ b/modules/cacsd/src/fortran/rilac.f @@ -0,0 +1,187 @@ + subroutine rilac(n,nn,a,na,c,d,rcond,x,w,nnw,z,eps,iwrk,wrk1,wrk2, + & ierr) +C!purpose +C +C to solve the continuous time algebraic equation +C +C trans(a)*x + x*a + c - x*d*x = 0 +C +C where trans(a) denotes the transpose of a . +C +C!method +C +C the method used is laub's variant of the hamiltonian - +C eigenvector approach (schur method). +C +C!reference +C +C a.j. laub +C a schur method for solving algebraic riccati equations +C ieee trans. automat. control, vol. ac-25, 1980. +C +C! auxiliary routines +C +C orthes,ortran,balanc,balbak (eispack) +C dgeco,dgesl (linpack) +C hqror2,inva,exchgn,qrstep +C +C! calling sequence +C subroutine rilac(n,nn,a,na,c,d,rcond,x,w,nnw,z, +C + iwrk,wrk1,wrk2,ierr) +C +C integer n,nn,na,nnw,iwrk(nn),ierr +C double precision a(na,n),c(na,n),d(na,n) +C double precision rcond,x(na,n),w(nnw,nn),z(nnw,nn) +C double precision wrk1(nn),wrk2(nn) +C +C arguments in +C +C n integer +C -the order of a,c,d and x +C +C na integer +C -the declared first dimension of a,c,d and x +C +C nn integer +C -the order of w and z +C nn = n + n +C +C nnw integer +C -the declared first dimension of w and z +C +C +C a double precision(n,n) +C +C c double precision(n,n) +C +C d double precision(n,n) +C +C arguments out +C +C x double precision(n,n) +C - x contains the solution matrix +C +C w double precision(nn,nn) +C - w contains the ordered real upper-triangular +C form of the hamiltonian matrix +C +C z double precision(nn,nn) +C - z contains the transformation matrix which +C reduces the hamiltonian matrix to the ordered +C real upper-triangular form +C +C rcond double precision +C - rcond contains an estimate of the reciprocal +C condition of the n-th order system of algebraic +C equations from which the solution matrix is obtained +C +C ierr integer +C -error indicator set on exit +C +C ierr = 0 successful return +C +C ierr = 1 the real upper triangular form of +C the hamiltonian matrix cannot be +C appropriately ordered +C +C ierr = 2 the hamiltonian matrix has less than n +C eigenvalues with negative real parts +C +C ierr = 3 the n-th order system of linear +C algebraic equations, from which the +C solution matrix would be obtained, is +C singular to working precision +C +C ierr = 4 the hamiltonian matrix cannot be +C reduced to upper-triangular form +C +C working space +C +C iwrk integer(nn) +C +C wrk1 double precision(nn) +C +C wrk2 double precision(nn) +C +C!originator +C +C control systems research group, dept. eecs, kingston +C polytechnic, penrhyn rd.,kingston-upon-thames, england. +C +C! comments +C if there is a shortage of storage space, then the +C matrices c and x can share the same locations, +C but this will, of course, result in the loss of c. +C +C******************************************************************* +C + integer n,nn,na,nnw,iwrk(nn),ierr + double precision a(na,n),c(na,n),d(na,n) + double precision rcond,x(na,n),w(nnw,nn),z(nnw,nn) + double precision wrk1(nn),wrk2(nn) +C +C local declarations: +C + integer i,j,low,igh,ni,nj + double precision eps,t(1) + integer folhp + external folhp + logical fail +C +C +C eps is a machine dependent parameter specifying +C the relative precision of realing point arithmetic. +C +C initialise the hamiltonian matrix associated with the problem +C + do 10 j = 1,n + nj = n + j + do 10 i = 1,n + ni = n + i + w(i,j) = a(i,j) + w(ni,j) = -c(i,j) + w(i,nj) = -d(i,j) + w(ni,nj) = -a(j,i) + 10 continue +C + call balanc(nnw,nn,w,low,igh,wrk1) +C + call orthes(nn,nn,1,nn,w,wrk2) + call ortran(nn,nn,1,nn,w,wrk2,z) + call hqror2(nn,nn,1,nn,w,t,t,z,ierr,11) + if (ierr .ne. 0) goto 70 + call inva(nn,nn,w,z,folhp,eps,ndim,fail,iwrk) +C + if (ierr .ne. 0) goto 40 + if (ndim .ne. n) goto 50 +C + call balbak(nnw,nn,low,igh,wrk1,nn,z) +C +C + call dgeco(z,nnw,n,iwrk,rcond,wrk1) + if (rcond .lt. eps) goto 60 +C + do 30 j = 1,n + nj = n + j + do 20 i = 1,n + x(i,j) = z(nj,i) + 20 continue + call dgesl(z,nnw,n,iwrk,x(1,j),1) + 30 continue + goto 100 +C + 40 ierr = 1 + goto 100 +C + 50 ierr = 2 + goto 100 +C + 60 ierr = 3 + goto 100 +C + 70 ierr = 4 + goto 100 +C + 100 return + end + diff --git a/modules/cacsd/src/fortran/rilac.lo b/modules/cacsd/src/fortran/rilac.lo new file mode 100755 index 000000000..74027bc4e --- /dev/null +++ b/modules/cacsd/src/fortran/rilac.lo @@ -0,0 +1,12 @@ +# src/fortran/rilac.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rilac.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/rootgp.f b/modules/cacsd/src/fortran/rootgp.f new file mode 100755 index 000000000..ccd74e11a --- /dev/null +++ b/modules/cacsd/src/fortran/rootgp.f @@ -0,0 +1,53 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine rootgp(ngp,gpp,nbeta,beta,ierr,w) +c +c +c Entree : - gpp. est le tableau contenant les coeff du polynome +c gpp(z) et dont le degre est ngp. +c - ngp. est le degre de gp(z). +c - w tableau de travail de taille 3*ngp+1 +c Sortie : - beta. est le tableau contenant les racines du +c polynome gpp(z) reelles comprises entre -2 et 2. +c - nbeta. est le nombre de ces racines. +c +c! + implicit double precision (a-h,o-z) + dimension gpp(ngp+1),beta(*),w(*) + logical fail + integer ierr + common /arl2c/ info,i1 +c +c decoupage du tableau de travail +c + kpol=1 + kzr=kpol+ngp+1 + kzi=kzr+ngp + kfree=kzi+ngp +c + call dcopy(ngp+1,gpp,-1,w(kpol),1) + call rpoly(w(kpol),ngp,w(kzr),w(kzi),fail) + nbeta=0 + do 110 j=0,ngp-1 + if (w(kzi+j).eq.0.0d+0.and.abs(w(kzr+j)).le.2.0d+0) then + nbeta=nbeta+1 + beta(nbeta)=w(kzr+j) + endif + 110 continue + if (nbeta.eq.0) then +c if(info.ge.2) then +c print*,' Problem : Cannot find a possible value for Beta' +c print*,' Stopping execution immediately' +c endif + ierr=4 + return + endif + return + end diff --git a/modules/cacsd/src/fortran/rootgp.lo b/modules/cacsd/src/fortran/rootgp.lo new file mode 100755 index 000000000..b7e57f418 --- /dev/null +++ b/modules/cacsd/src/fortran/rootgp.lo @@ -0,0 +1,12 @@ +# src/fortran/rootgp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rootgp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/rtitr.f b/modules/cacsd/src/fortran/rtitr.f new file mode 100755 index 000000000..7c126948d --- /dev/null +++ b/modules/cacsd/src/fortran/rtitr.f @@ -0,0 +1,242 @@ +C/MEMBR ADD NAME=RTITR,SSI=0 + + +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - Serge Steer +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine rtitr(nin,nout,nu,num,inum,dgnum,den,iden,dgden, + & up,u,iu,yp,y,iy,job,iw,w,ierr) +c!but +c le sous programme rtitr calcule la reponse temporelle d'un systeme +c dynamique lineaire discret MIMO represente par sa forme de +c transfert: D**-1*N soumis a une entree U +c!liste d'appel +c subroutine rtitr(nin,nout,nu,num,inum,dgnum,den,iden,dgden, +c & up,u,iu,yp,y,iy,job,iw,w,ierr) +c +c integer nin,nout,nu,inum,dgnum,iden,dgden,iu,iy,job,ierr,iw(nout) +c double precision num(inum,nin*(dgnum+1)),den(iden,nout*(dgden+1)) +c double precision up(iu,dgden+1),u(iu,nu),yp(iy,dgden+1) +c double precision y(iy,nu+dgden-dgnum),w(nout) +c +c nin : nombre d'entrees du systeme dynamique, nombre de colonnes +c de la matrice N. +c nout : nombre de sorties du systeme dynamique, nombre de lignes +c de la matrice N et dimensions de D. +c nu : nombre d'echantillon de la reponse temporelle a calculer +c num : tableau contenant les coefficients (matriciels) du polynome +c matriciel numerateur N. Si N=somme(Nk*z**k) alors num +c est la matrice bloc : num=[N ,N ,....N ] +c 0 1 dgnum+1 +c num est modifie par l'execution (normalisation par le +c coefficient de plus haut degre de D D(dgden+1) ) +c inum : nombre de ligne du tableau num dans le programme appelant +c dgnum : degre du polynome matriciel numerateur +c den : tableau contenant les coefficients (matriciels) du polynome +c matriciel denominateur D. Si D=somme(Dk*z**k) alors den +c est la matrice bloc : den=[D ,D ,....D ] +c 0 1 dgden+1 +c den est modifie par l'execution (normalisation par la +c matrice de plus haut degre D(dgden+1) ) +c iden : nombre de ligne du tableau den dans le programme appelant +c dgden : degre du polynome matriciel denominateur +c up : tableau contenant eventuellement (voir job) les dgden+1 +c entrees passees du systeme stockees par colonnes: +c up=[U , ....,U ] . Si omis up est pris nul. +c -dgden -1 +c u : tableau contenant les nu echantillons d'entrees soumis +c au systeme . u=[U , .... , U ] +c 0 nu-1 +c iu : nombre de lignes des tableaux up et u dans la programme +c appelant +c yp : tableau contenant eventuellement (voir job) les dgden+1 +c sorties passees du systeme stockees par colonnes: +c yp=[Y , .... , Y ] . Si omis yp est pris nul. +c -dgden -1 +c y : tableau contenant apres execution les nt echantillons +c de sorties du systeme . y=[Y ,....,Y ] +c 0 nu+dgden-dgnum-1 +c iy : nombre de lignes des tableaux yp et y dans la programme +c appelant +c job : Si job = +-1 le programme suppose que les valeurs passees +c de U et Y sont nulles up et yp ne sont alors +c pas references +c Si job = +-2 les valeurs passees de U et Y sont donnees +c par up et yp +c job > 0 le sous programme effectue la normalisation +c job < 0 on suppose que la normalisation a deja ete effectuee +c (rappel de rtitr pour le meme systeme) +c iw ,w : tableaux de travail. En retour w(1) contient le +c conditionnement evalue par dgeco. +c ierr : indicateur d'erreur: +c 0 --> ok +c 1 --> la matrice coefficient de plus haut degre de D est +c mal conditionnee le conditionnement est estime par +c dgeco et le sous programme teste s'il est +c negligeable par rapport a 1. Dans ce cas le calcul +c est effectue +c 2 --> la matrice coefficient de plus haut degre de D n'est +c pas inversible. Calcul abandonne. +c -1 --> argument d'appel incorrect (dimensionnement des +c tableaux negatif ou nul ou degre de N et D negatif) +c!sous programmes appeles +c dgeco,dgesl (linpack) +c ddif,ddad (blas) +c dmmul (blas etendu) +c!methode +c +c +inf +inf dn dd +c --- --- --- --- +c \ -k \ -k \ i \ j +c si U=> U z , Y= > Y z , N= > N z , D= > D z +c / k / k / i / j +c --- --- --- --- +c -inf -inf 0 0 +c +c la sortie Y verifie l'equation polynomiale D*Y=N*U qui peut s'ecrire: +c +c dd-1 dn +c --- --- +c \ \ +c D Y = - > D Y + > N U -inf < i < +inf +c dd i+dd / k i+k / l i+l +c --- --- +c 0 0 +c +c Si D est inversible l'equation precedente donne directement la +c dd +c recursion permettant de calculer Y connaissant les dd echantillons +c i+dd +c precedents de Y et U +c + + integer nin,nout,nu,inum,dgnum,iden,dgden,iu,iy,ierr,iw(nout) + double precision num(inum,*),den(iden,*) + double precision up(iu,*),u(iu,nu),yp(iy,*),y(iy,*),w(nout) +c + double precision rcond,dmx,ddot +c + ierr=0 + nt=nu+dgden-dgnum + if(nin.le.0.or.nout.le.0.or.nt.le.0.or.inum.le.0.or.iden.le.0 + & .or.iu.le.0.or.iy.le.0.or.dgden.lt.0.or.dgnum.lt.0) then + ierr=-1 + return + endif +c + if(nout.eq.1) goto 40 +c initialisation de la reponse + do 01 k=1,nout + 01 call dset(nt,0.0d+0,y(k,1),iy) + if(job.gt.0) then +c +c normalisation +c +c factorisation du coeff de plus haut degre en z**-1 de d + kd=1+dgden*nout + call dgeco(den(1,kd),iden,nout,iw,rcond,w) + if (rcond .eq. 0.0d+0) then + ierr=2 + w(1)=0.0d+0 + return + endif + if (1.0d+0+rcond.le.1.0d+0 ) ierr=1 +c normalisation de N et D + if(dgden.gt.0) then + do 10 k=1,nout*dgden + call dgesl (den(1,kd),iden,nout,iw,den(1,k),0) + 10 continue + endif + do 11 k=1,nin*(dgnum+1) + call dgesl (den(1,kd),iden,nout,iw,num(1,k),0) + 11 continue + endif +c +c recursion +c + do 30 n=0,nt-1 + if(dgden-n.lt.1.or.abs(job).eq.1) goto 25 +c termes faisant intervenir les valeurs passees + kd=1 + do 20 k=1,dgden-n + call dmmul(den(1,kd),iden,yp(1,n+k),iy,w,nout,nout,nout,1) + call ddif(nout,w,1,y(1,1+n),1) + kd=kd+nout + 20 continue + ln=1 + do 21 l=1,min(dgden-n,dgnum+1) + call dmmul(num(1,ln),inum,up(1,n+l),iu,w,nout,nout,nin,1) + call dadd(nout,w,1,y(1,1+n),1) + ln=ln+nin + 21 continue + 22 continue +c + 25 continue +c autres termes + mx=max(1,dgden-n+1) + if(mx.gt.dgden) goto 27 + kd=1+(mx-1)*nout + do 26 k=mx,dgden + call dmmul(den(1,kd),iden,y(1,n+k-dgden),iy,w,nout,nout,nout,1) + call ddif(nout,w,1,y(1,1+n),1) + kd=kd+nout + 26 continue + 27 if(mx.gt.dgnum+1) goto 30 + ln=1+(mx-1)*nin + do 28 l=mx,dgnum+1 + call dmmul(num(1,ln),inum,u(1,n+l-dgden),iu,w,nout,nout,nin,1) + call dadd(nout,w,1,y(1,1+n),1) + ln=ln+nin + 28 continue + 30 continue + w(1)=rcond + return +c + 40 continue +c cas particulier d'un systeme mono-sortie. Evaluation plus directe +c +c initialisation de la reponse + call dset(nt,0.0d+0,y,iy) + if(job.gt.0) then + dmx=den(1,dgden+1) + if( dmx.eq.0) then + ierr=2 + w(1)=0.0d+0 + return + endif + dmx=1.0d+0/dmx + call dscal(dgden+1,dmx,den,iden) + call dscal(nin*(dgnum+1),dmx,num,inum) + endif +c recursion + do 50 n=0,nt-1 + if(dgden-n.lt.1.or.abs(job).eq.1) goto 42 +c termes faisant intervenir les valeurs passees + y(1,1+n)=-ddot(dgden-n,den,iden,yp(1,n+1),iy) + do 41 l=1,nin + y(1,1+n)=y(1,1+n)+ddot(min(dgden-n,dgnum+1),num(1,l),inum*nin, + & up(l,n+1),iu) + 41 continue + 42 continue +c autres termes + mx=max(1,dgden-n+1) + if(mx.gt.dgden) goto 43 + y(1,1+n)=y(1,1+n)-ddot(dgden-mx+1,den(1,mx),iden, + & y(1,n+mx-dgden),iy) + 43 if(mx.gt.dgnum+1) goto 50 + ln=(mx-1)*nin + do 44 l=1,nin + y(1,1+n)=y(1,1+n)+ddot(dgnum+2-mx,num(1,ln+l),inum*nin, + & u(l,n+mx-dgden),iu) + 44 continue + 50 continue + w(1)=1.0d+0 + return +c + end diff --git a/modules/cacsd/src/fortran/rtitr.lo b/modules/cacsd/src/fortran/rtitr.lo new file mode 100755 index 000000000..0dec2dfea --- /dev/null +++ b/modules/cacsd/src/fortran/rtitr.lo @@ -0,0 +1,12 @@ +# src/fortran/rtitr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rtitr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/scapol.f b/modules/cacsd/src/fortran/scapol.f new file mode 100755 index 000000000..7ac40b04b --- /dev/null +++ b/modules/cacsd/src/fortran/scapol.f @@ -0,0 +1,40 @@ +C/MEMBR ADD NAME=SCAPOL,SSI=0 + +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine scapol(na,a,nb,b,y) +c!but +c cette subroutine a pour but de calculer le produit +c scalaire de deux polynomes +c!liste d'appel +c subroutine scapol(na,a,nb,b,y) +c Entree : +c a. est le premier polynome de degre na +c b. est le second polynome du produit, et est de degre nb +c +c Sortie : +c y. est le resultat du produit scalaire <a,b> +c! + implicit double precision (a-h,o-y) + dimension a(0:*),b(0:*) +c + if (na.ge.nb) then + nmax=nb + else + nmax=na + endif +c + aux=0.0d+0 + do 20 k=0,nmax + aux=aux + a(k)*b(k) + 20 continue + y=aux +c + end diff --git a/modules/cacsd/src/fortran/scapol.lo b/modules/cacsd/src/fortran/scapol.lo new file mode 100755 index 000000000..f8536a296 --- /dev/null +++ b/modules/cacsd/src/fortran/scapol.lo @@ -0,0 +1,12 @@ +# src/fortran/scapol.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/scapol.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/shrslv.f b/modules/cacsd/src/fortran/shrslv.f new file mode 100755 index 000000000..8bf83001d --- /dev/null +++ b/modules/cacsd/src/fortran/shrslv.f @@ -0,0 +1,199 @@ + subroutine shrslv(a,b,c,m,n,na,nb,nc,eps,cond,rmax,fail) +c +c!purpose +c shrslv is a fortran iv subroutine to solve the real matrix +c equation ax + xb = c, where a is in lower real schur form +c and b is in upper real schur form, +c +c!calling sequence +c +c subroutine shrslv(a,b,c,m,n,na,nb,nc,eps,cond,rmax,fail) +c a a doubly subscripted array containg the matrix a in +c lower schur form +c +c b a doubly subscripted array containing tbe matrix b +c in upper real schur form +c +c c a doubly subscripted array containing the matrix c. +c +c m the order of the matrix a +c +c n the order of the matrix b +c +c na the first dimension of the array a +c +c nb the first dimension of the array b +c +c nc the first dimension of the array c +c +c eps tolerance on a(k,k)+b(l,l) +c if |a(k,k)+b(l,l)|<eps algorithm suppose that |a(k,k)+b(l,l)|=eps +c +c cond minimum allowed conditionnement for linear systems +c if cond .le. 0 no estimation of conditionnement is done +c +c rmax maximum allowed size of any element of the transformation +c +c fail indicates if shrslv failed +c +c!auxiliary routines +c ddot (blas) +c dgeco dgefa dgesl (linpack) +c dbas sqrt (fortran) +c!originator +c Bartels and Stewart +c! +c + integer m, n, na, nb, nc + double precision a, b, c, rmax + dimension a(na,m), b(nb,n), c(nc,n) + logical fail +c internal variables +c + integer k,km1,dk,kk,l,lm1,dl,ll,i,j,nsys,ipvt(4),info + double precision t,p,zero,rcond,cond,const,z,ddot,eps + dimension t(4,4),p(4),z(4) + data zero /0.0d+0/ + if(cond.gt.zero) const = sqrt(sqrt(cond)) +c + info = 0 + fail = .true. + l = 1 + 10 lm1 = l - 1 + dl = 1 + if (l.eq.n) go to 20 + if (b(l+1,l).ne.zero) dl = 2 + 20 ll = l + dl - 1 + if (l.eq.1) go to 60 + do 50 j=l,ll + do 40 i=1,m + c(i,j)=c(i,j)-ddot(lm1,c(i,1),nc,b(1,j),1) + 40 continue + 50 continue + 60 k = 1 + 70 km1 = k - 1 + dk = 1 + if (k.eq.m) go to 80 + if (a(k,k+1).ne.zero) dk = 2 + 80 kk = k + dk - 1 + if (k.eq.1) go to 120 + do 110 i=k,kk + do 100 j=l,ll + c(i,j) = c(i,j) - ddot(km1,a(i,1),na,c(1,j),1) + 100 continue + 110 continue + 120 continue +c write(6,'(''dl='',i1,'' dk='',i1)') dl,dk + if (dl.eq.2) go to 160 + if (dk.eq.2) go to 130 + t(1,1) = a(k,k) + b(l,l) +c write(6,'(e10.3,3x,e10.3)') t(1,1),c(k,l) + if (abs(t(1,1)).lt.eps) t(1,1)=sign(eps,t(1,1)) + c(k,l) = c(k,l)/t(1,1) +c write(6,'(''c='',e10.3,'' rmax='',e10.3)') c(k,l),rmax + + if (abs(c(k,l)).ge.rmax) return + go to 220 + 130 t(1,1) = a(k,k) + b(l,l) + t(1,2) = a(k,kk) + t(2,1) = a(kk,k) + t(2,2) = a(kk,kk) + b(l,l) + p(1) = c(k,l) + p(2) = c(kk,l) +c write(6,'(e10.3,3x,e10.3,3x,e10.3)') t(1,1),t(1,2),p(1) +c write(6,'(e10.3,3x,e10.3,3x,e10.3)') t(2,1),t(2,2),p(2) + nsys = 2 + if (cond.gt.zero) go to 140 + call dgefa(t, 4, nsys, ipvt, info) + if (info.gt.0) return + go to 150 + 140 continue + call dgeco(t, 4, nsys, ipvt, rcond, z) + if (rcond.lt.const) return + 150 continue + call dgesl(t, 4, nsys, ipvt, p, 0) +c write(6,'(''c='',e10.3,'' rmax='',e10.3)') c(k,l),rmax +c write(6,'(''c='',e10.3,'' rmax='',e10.3)') c(kk,l),rmax + c(k,l) = p(1) + if (abs(c(k,l)).ge.rmax) return + c(kk,l) = p(2) + if (abs(c(kk,l)).ge.rmax) return + go to 220 + 160 if (dk.eq.2) go to 190 + t(1,1) = a(k,k) + b(l,l) + t(1,2) = b(ll,l) + t(2,1) = b(l,ll) + t(2,2) = a(k,k) + b(ll,ll) + p(1) = c(k,l) + p(2) = c(k,ll) +c write(6,'(e10.3,3x,e10.3,3x,e10.3)') t(1,1),t(1,2),p(1) +c write(6,'(e10.3,3x,e10.3,3x,e10.3)') t(2,1),t(2,2),p(2) + nsys = 2 + if (cond.gt.zero) go to 170 + call dgefa(t, 4, nsys, ipvt, info) + if (info.gt.0) return + go to 180 + 170 continue + call dgeco(t, 4, nsys, ipvt, rcond, z) + if (rcond.lt.const) return + 180 continue + call dgesl(t, 4, nsys, ipvt, p, 0) +c write(6,'(''c='',e10.3,'' rmax='',e10.3)') c(k,l),rmax +c write(6,'(''c='',e10.3,'' rmax='',e10.3)') c(kk,l),rmax + c(k,l) = p(1) + if (abs(c(k,l)).ge.rmax) return + c(k,ll) = p(2) + if (abs(c(k,ll)).ge.rmax) return + go to 220 + 190 t(1,1) = a(k,k) + b(l,l) + t(1,2) = a(k,kk) + t(1,3) = b(ll,l) + t(1,4) = zero + t(2,1) = a(kk,k) + t(2,2) = a(kk,kk) + b(l,l) + t(2,3) = zero + t(2,4) = t(1,3) + t(3,1) = b(l,ll) + t(3,2) = zero + t(3,3) = a(k,k) + b(ll,ll) + t(3,4) = t(1,2) + t(4,1) = zero + t(4,2) = t(3,1) + t(4,3) = t(2,1) + t(4,4) = a(kk,kk) + b(ll,ll) + p(1) = c(k,l) + p(2) = c(kk,l) + p(3) = c(k,ll) + p(4) = c(kk,ll) + do 191 j=1,4 +c write(6,'(5(e10.3,3x))') (t(j,i),i=1,4),p(j) + 191 continue + nsys = 4 + if (cond.gt.zero) go to 200 + call dgefa(t, 4, nsys, ipvt, info) + if (info.gt.0) return + go to 210 + 200 continue + call dgeco(t, 4, nsys, ipvt, rcond, z) + if (rcond.lt.const) return + 210 continue + call dgesl(t, 4, nsys, ipvt, p, 0) +c write(6,'(''c='',e10.3,'' rmax='',e10.3)') c(k,l),rmax +c write(6,'(''c='',e10.3,'' rmax='',e10.3)') c(kk,l),rmax +c write(6,'(''c='',e10.3,'' rmax='',e10.3)') c(k,ll),rmax +c write(6,'(''c='',e10.3,'' rmax='',e10.3)') c(kk,ll),rmax + c(k,l) = p(1) + if (abs(c(k,l)).ge.rmax) return + c(kk,l) = p(2) + if (abs(c(kk,l)).ge.rmax) return + c(k,ll) = p(3) + if (abs(c(k,ll)).ge.rmax) return + c(kk,ll) = p(4) + if (abs(c(kk,ll)).ge.rmax) return + 220 k = k + dk + if (k.le.m) go to 70 + l = l + dl + if (l.le.n) go to 10 + fail = .false. + return + end diff --git a/modules/cacsd/src/fortran/shrslv.lo b/modules/cacsd/src/fortran/shrslv.lo new file mode 100755 index 000000000..f05b46fb3 --- /dev/null +++ b/modules/cacsd/src/fortran/shrslv.lo @@ -0,0 +1,12 @@ +# src/fortran/shrslv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/shrslv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/sszer.f b/modules/cacsd/src/fortran/sszer.f new file mode 100755 index 000000000..1130e9e40 --- /dev/null +++ b/modules/cacsd/src/fortran/sszer.f @@ -0,0 +1,622 @@ + subroutine sszer(n,m,p,a,na,b,c,nc,d,eps,zeror,zeroi,nu,irank,af, + & naf,bf,mplusn,wrka,wrk1,nwrk1,wrk2,nwrk2,ierr) +C +C! calling sequence +C +C subroutine sszer(n,m,p,a,na,b,c,nc,d,zeror,zeroi,nu,irank, +C 1 af,naf,bf,mplusn,wrka,wrk1,nwrk1,wrk2,nwrk2,ierr) +C +C integer n,m,p,na,nc,nu,irank,nabf,mplusn,nwrk1,nwrk2,ierr +C +C double precision a(na,n),b(na,m),c(nc,n),d(nc,m),wrka(na,n) +C double precision af(naf,mplusn),bf(naf,mplusn) +C double precision wrk1(nwrk1),wrk2(nwrk2) +C double precision zeror(n),zeroi(n) +C +C arguments in +C +C n integer +C -the number of state variables in the system +C +C m integer +C -the number of inputs to the system +C +C p integer +C -the number of outputs from the system +C +C a double precision (n,n) +C -the state dynamics matrix of the system +C +C na integer +C -the declared first dimension of matrices a and b +C +C b double precision (n,m) +C -the input/state matrix of the system +C +C c double precision (p,n) +C -the state/output matrix of the system +C +C nc integer +C -the declared first dimension of matrices c and d +C +C d double precision (p,m) +C -the input/output matrix of the system +C +C naf integer +C -the declared first dimension of matrices af and bf +C naf must be at least n + p +C +C mplusn integer +C -the second dimension of af and bf. mplusn must be +C at least m + n . +C +C nwrk1 integer +C -the length of work vector wrk1. +C nwrk1 must be at least max(m,p) +C +C nwrk2 integer +C -the length of work vector wrk2. +C nwrk2 must be at least max(n,m,p)+1 +C +C arguments out +C +C nu integer +C -the number of (finite) invariant zeros +C +C irank integer +C -the normal rank of the transfer function +C +C zeror double precision (n) +C zeroi double precision (n) +C -the real and imaginary parts of the zeros +C +C af double precision ( n+p , m+n ) +C bf double precision ( n+p , m+n ) +C -the coefficient matrices of the reduced pencil +C +C ierr integer +C -error indicator +C +C ierr = 0 successful return +C +C ierr = 1 incorrect dimensions of matrices +C +C ierr = 2 attempt to divide by zero +C +C ierr = i > 2 ierr value i-2 from qitz (eispack) +C +C!working space +C +C wrka double precision (na,n) +C +C wrk1 double precision (nwrk1) +C +C wrk2 double precision (nwrk2) +C +C!purpose +C +C to compute the invariant zeros of a linear multivariable +C system given in state space form. +C +C!method +C +C this routine extracts from the system matrix of a state-space +C system a,b,c,d a regular pencil lambda * bf - af +C which has the invariant zeros of the system as generalized +C eigenvalues. +C +C!reference +C +C emami-naeini, a. and van dooren, p. +C 'computation of zeros of linear multivariable systems' +C report na-80-03, computer science department, stanford univ. +C +C!originator +C +C a.emami-naeini, computer science department, +C stanford university. +C Copyrigth SLICE +C + integer n,m,p,na,nc,nu,irank,naf,mplusn,nwrk1,nwrk2,ierr +C + double precision a(na,n),b(na,m),c(nc,n),d(nc,m) + double precision wrka(na,n),zeror(n),zeroi(n) + double precision af(naf,mplusn),bf(naf,mplusn),wrk1(nwrk1), + & wrk2(nwrk2) + double precision eps,sum,heps,xxx(1,1) +C +C local variables: +C + logical zero,matq,matz +C + integer mm,nn,pp,mu,iro,isigma,numu,mnu,numu1,mnu1,i,j,j1 + integer mj,ni,nu1 +C + double precision s + ierr = 1 + if (na .lt. n) return + if (nc .lt. p) return + if (naf .lt. n+p) return + if (nwrk1 .lt. m) return + if (nwrk1 .lt. p) return + if (nwrk2 .lt. n) return + if (nwrk2 .lt. m) return + if (nwrk2 .lt. p) return + if (mplusn .lt. m+n) return + ierr = 0 +C construct the compound matrix (b a) of dimension +C (d c) +C (n + p) * (m + n) +C + sum = 0.0d+0 + do 30 i = 1,n + do 10 j = 1,m + bf(i,j) = b(i,j) + sum = sum + (b(i,j)*b(i,j)) + 10 continue + do 30 j = 1,n + mj = m + j + bf(i,mj) = a(i,j) + sum = sum + (a(i,j)*a(i,j)) + 30 continue +C + do 60 i = 1,p + ni = n + i + do 40 j = 1,m + bf(ni,j) = d(i,j) + sum = sum + (d(i,j)*d(i,j)) + 40 continue + do 60 j = 1,n + mj = m + j + bf(ni,mj) = c(i,j) + sum = sum + (c(i,j)*c(i,j)) + 60 continue +C + heps = 10.0*eps * sqrt(sum) +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 + iro = p + isigma = 0 +C + + call preduc(bf,naf,mplusn,m,n,p,heps,iro,isigma,mu,nu,wrk1,nwrk1, + & wrk2,nwrk2) +C + irank = mu + if (nu .eq. 0) return +C +C pertranspose the system +C + numu = nu + mu + mnu = m + nu + numu1 = numu + 1 + mnu1 = mnu + 1 + do 70 i = 1,numu + ni = numu1 - i + do 70 j = 1,mnu + mj = mnu1 - j + af(mj,ni) = bf(i,j) + 70 continue +C + mm = m + nn = n + pp = p + if (mu .eq. mm) goto 80 + pp = mm + nn = nu + mm = mu +C +C reduce the system to one with the same invariant zeros and with +C d square and of full rank +C + iro = pp - mm + isigma = mm +C + call preduc(af,naf,mplusn,mm,nn,pp,heps,iro,isigma,mu,nu,wrk1, + & nwrk1,wrk2,nwrk2) +C + + if (nu .eq. 0) return + mnu = mm + nu + 80 continue + do 100 i = 1,nu + ni = mm + i + do 90 j = 1,mnu + bf(i,j) = 0.0d+0 + 90 continue + bf(i,ni) = 1.0d+0 + 100 continue +C + if (irank .eq. 0) return + nu1 = nu + 1 + numu = nu + mu + j1 = mm + do 120 i = 1,mm + j1 = j1 - 1 + do 110 j = 1,nu1 + mj = j1 + j + wrk2(j) = af(numu,mj) + 110 continue +C + call house(wrk2,nu1,nu1,heps,zero,s) + call tr2(af,naf,mplusn,wrk2,s,1,numu,j1,nu1) + call tr2(bf,naf,mplusn,wrk2,s,1,nu,j1,nu1) +C + numu = numu - 1 + 120 continue + matz = .false. + matq = .false. +Cc + call qhesz(naf,nu,af,bf,matq,xxx,matz,wrka) + call qitz(naf,nu,af,bf,eps,matq,xxx,matz,wrka,ierr) + if (ierr .ne. 0) goto 150 +Cc + call qvalz(naf,nu,af,bf,eps,zeror,zeroi,wrk2,matq,xxx,matz,wrka) +Cc +C do 130 i = 1,nu +C if (wrk2(i) .eq. 0.0d+0) go to 140 +C zeror(i) = zeror(i)/wrk2(i) +C zeroi(i) = zeroi(i)/wrk2(i) +C 130 continue +Cc +Cc successful completion +Cc + ierr = 0 + return +Cc +Cc attempt to divide by zero +Cc +C 140 ierr = 2 +C return +Cc +Cc failure in subroutine qzit +Cc + 150 ierr = ierr + 2 + return + end + subroutine preduc(abf,naf,mplusn,m,n,p,heps,iro,isigma,mu,nu, + 1 wrk1,nwrk1,wrk2,nwrk2) +c%calling sequence +c subroutine preduc(abf,naf,mplusn,m,n,p,heps,iro,isigma,mu,nu, +c 1 wrk1,nwrk1,wrk2,nwrk2) +c integer naf,mplusn,m,n,p,iro,isigma,mu,nu,nwrk1,nwrk2 +c double precision abf(naf,mplusn),wrk1(nwrk1),wrk2(nwrk2) +c +c%purpose +c +c this routine is only to be called from slice routine sszer +c% + integer naf,mplusn,m,n,p,iro,isigma,mu,nu,nwrk1,nwrk2 +c + double precision abf(naf,mplusn),wrk1(nwrk1),wrk2(nwrk2) +c +c local variables: +c + integer i,j,i1,m1,n1,i2,mm1,mn1,irj,itau,iro1,icol + integer ibar,numu,irow +c + logical zero +c + double precision s,temp +c + double precision sum,heps +c +c + mu = p + nu = n + 10 if (mu .eq. 0) return + iro1 = iro + mnu = m + nu + numu = nu + mu + if (m .eq. 0) go to 120 + iro1 = iro1 + 1 + irow = nu + if (isigma .le. 1) go to 40 +c +c compress rows of d: first exploit triangular shape +c + m1 = isigma - 1 + do 30 icol = 1,m1 + do 20 j = 1,iro1 + irj = irow + j + wrk2(j) = abf(irj,icol) + 20 continue +c + call house(wrk2,iro1,1,heps,zero,s) +c + call tr1(abf,naf,mplusn,wrk2,s,irow,iro1,icol,mnu) +c + irow = irow + 1 + 30 continue +c +c continue with householder transformation with pivoting +c + 40 if (isigma .ne. 0) go to 45 + isigma = 1 + iro1 = iro1 - 1 + 45 if (isigma .eq. m) go to 60 + do 55 icol = isigma,m + sum = 0.0d+0 + do 50 j = 1,iro1 + irj = irow + j + sum = sum + (abf(irj,icol) * abf(irj,icol) ) + 50 continue + wrk1(icol) = sum + 55 continue +c + 60 continue + do 100 icol = isigma,m +c +c pivot if necessary +c + if (icol .eq. m) go to 80 +c + call pivot(wrk1,temp,ibar,icol,m) +c + if (ibar .eq. icol) go to 80 + wrk1(ibar) = wrk1(icol) + wrk1(icol) = temp + do 70 i = 1,numu + temp = abf(i,icol) + abf(i,icol) = abf(i,ibar) + 70 abf(i,ibar) = temp +c +c perform householder transformation +c + 80 continue + do 90 i = 1,iro1 + irj = irow + i + 90 wrk2(i) = abf(irj,icol) +c + call house(wrk2,iro1,1,heps,zero,s) +c + if (zero) go to 120 + if (iro1 .eq. 1) return +c + call tr1(abf,naf,mplusn,wrk2,s,irow,iro1,icol,mnu) +c + irow = irow + 1 + iro1 = iro1 - 1 + do 100 j = icol,m + 100 wrk1(j) = wrk1(j) - (abf(irow,j) * abf(irow,j) ) +c + 120 itau = iro1 + isigma = mu - itau +c +c compress the columns of c +c + i1 = nu + isigma + mm1 = m + 1 + n1 = nu + if (itau .eq. 1) go to 140 + do 135 i = 1,itau + irj = i1 + i + sum = 0.0d+0 + do 130 j = mm1,mnu + 130 sum = sum + (abf(irj,j) * abf(irj,j) ) + 135 wrk1(i) = sum +c + 140 continue + do 200 iro1 = 1,itau + iro = iro1 - 1 + i = itau - iro + i2 = i + i1 +c +c pivot if necessary +c + if (i .eq. 1) go to 160 +c + call pivot(wrk1,temp,ibar,1,i) +c + if (ibar .eq. i) go to 160 + wrk1(ibar) = wrk1(i) + wrk1(i) = temp + irj = ibar + i1 + do 150 j = mm1,mnu + temp = abf(i2,j) + abf(i2,j) = abf(irj,j) + 150 abf(irj,j) = temp +c +c perform householder transformation +c + 160 do 170 j = 1,n1 + irj = m + j + 170 wrk2(j) = abf(i2,irj) +c + call house(wrk2,n1,n1,heps,zero,s) +c + if (zero) go to 210 + if (n1 .eq. 1) go to 220 +c + call tr2(abf,naf,mplusn,wrk2,s,1,i2,m,n1) +c + mn1 = m + n1 +c + call tr1(abf,naf,mplusn,wrk2,s,0,n1,1,mn1) +c + do 190 j = 1,i + irj = i1 + j + 190 wrk1(j) = wrk1(j) - (abf(irj,mn1) * abf(irj,mn1) ) + mnu = mnu - 1 + 200 n1 = n1 - 1 +c + iro = itau + 210 nu = nu - iro + mu = isigma + iro + if (iro .eq. 0) return + go to 10 +c + 220 mu = isigma + nu = 0 +c + return + end + subroutine house(wrk2,k,j,heps,zero,s) +c +c warning - this routine is only to be called from slice routine +c sszer +c +c% purpose +c this routine constructs a householder transformation h = i-s.uu +c that 'mirrors' a vector wrk2(1,...,k) to the j-th unit vector. +c if norm(wrk2) < heps, zero is put equal to .true. +c upon return, u is stored in wrk2 +c +c% + integer k,j +c + double precision wrk2(k),heps,s +c + logical zero +c +c local variables: +c + integer i +c + double precision alfa,dum1 +c + double precision sum +c +c + zero = .true. + sum = 0.0d+0 + do 10 i = 1,k + 10 sum = sum + (wrk2(i) * wrk2(i) ) +c + alfa = sqrt(sum) + if (alfa .le. heps) return +c + zero = .false. + dum1 = wrk2(j) + if (dum1 .gt. 0.0d+0) alfa = -alfa + wrk2(j) = dum1 - alfa + s = 1.0d+0 / (sum - (alfa * dum1) ) +c + return + end + + subroutine tr1(a,na,n,u,s,i1,i2,j1,j2) +c% calling sequence +c +c subroutine tr1(a,na,n,u,s,i1,i2,j1,j2) +c +c%purpose +c +c this subroutine performs the householder transformation +c h = i - s.uu +c on the rows i1 + 1 to i1 + i2 of a, this from columns j1 to j2. +c% comments +c +c warning - this routine is only to be called from slice routine +c sszer +c +c% + integer na,n,i1,i2,j1,j2 +c + double precision a(na,n),u(i2),s +c +c local variables: +c + integer i,j,irj +c + double precision y +c + double precision sum +c +c + do 20 j = j1,j2 + sum = 0.0d+0 + do 10 i = 1,i2 + irj = i1 + i + 10 sum = sum + (u(i) * a(irj,j) ) +c + y = sum * s +c + do 20 i = 1,i2 + irj = i1 + i + 20 a(irj,j) = a(irj,j) - (u(i) * y) +c + return + end + + subroutine tr2(a,na,n,u,s,i1,i2,j1,j2) +c% calling sequence +c +c subroutine tr2(a,na,n,u,s,i1,i2,j1,j2) +c%purpose +c +c this routine performs the householder transformation h = i-s.uu +c on the columns j1 + 1 to j1 + j2 of a, this from rows i1 to i2. +c +c% comments +c +c warning - this routine is only to be called from slice routine +c sszer +c% + integer na,n,i1,i2,j1,j2 +c + double precision a(na,n),u(j2),s +c +c local variables: +c + integer i,j,irj +c + double precision y +c + double precision sum +c +c + do 20 i = i1,i2 + sum = 0.0d+0 + do 10 j = 1,j2 + irj = j1 + j + 10 sum = sum + (u(j) * a(i,irj) ) +c + y = sum * s +c + do 20 j = 1,j2 + irj = j1 + j + 20 a(i,irj) = a(i,irj) - (u(j) * y) +c + return + end + + subroutine pivot(vec,vmax,ibar,i1,i2) +c% calling sequence +c subroutine pivot(vec,vmax,ibar,i1,i2) +c integer ibar,i1,i2 +c double precision vec(i2),vmax +c +c% purpose +c +c this subroutine computes the maximal norm element (vthe max) +c of the vector vec(i1,...,i2), and its location ibar +c +c this routine is only to be called from slice routine sszer +c +c% + integer ibar,i1,i2 +c + double precision vec(i2),vmax +c +c local variables: +c + integer i,i11 +c +c + ibar = i1 + vmax = vec(i1) + if (i1 .ge. i2) go to 20 + i11 = i1 + 1 + do 10 i = i11,i2 + if (abs(vec(i) ) .lt. vmax) go to 10 + vmax = abs (vec(i) ) + ibar = i + 10 continue +c + 20 if (vec(ibar) .lt. 0.0d+0) vmax = -vmax +c + return + end diff --git a/modules/cacsd/src/fortran/sszer.lo b/modules/cacsd/src/fortran/sszer.lo new file mode 100755 index 000000000..7a83212fe --- /dev/null +++ b/modules/cacsd/src/fortran/sszer.lo @@ -0,0 +1,12 @@ +# src/fortran/sszer.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sszer.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/storl2.f b/modules/cacsd/src/fortran/storl2.f new file mode 100755 index 000000000..7f2055b53 --- /dev/null +++ b/modules/cacsd/src/fortran/storl2.f @@ -0,0 +1,223 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine storl2(neq,tq,tg,ng,imin,tabc,iback,ntback,tback, + & nch,mxsol,w,ierr) +C!but +C Lorsque un minimum local vient d'etre determine, cette +C procedure est appelee afin de verifier son originalite, +C et si elle est effective, de le stocker dans le tableau +C en construction, correspondant au degre de la recherche +C en cours. S'il n'est pas de ce degre, il est alors range +C dans le tableau 'tback' qui contient tout minimum origi- +C nal obtenu apres une sortie de face. +C!liste d'appel +C entrees : +C - neq. est le degre du minimum nouvellement obtenu. +C - tq. est le tableau contenant ses coefficients +C - imin. est le nombre des minimums de meme degre, +C deja reveles. +C - tabc. etant le tableau contenant ces minimums. +C - iback. est le nombre de minimums de degre +C quelconque, reveles apres une sortie de face. +C - ntback. est un tableau entier unicolonne contenant +C les degres de ces polynomes. +C - tback. est le tableau ou sont stockes ces polynomes. +C Ainsi, le ieme polynome, de degre ntback(i), a +C ses coeff dans la ieme ligne, c-a-d de tback(i,0) +C a tback(i,ntback(i)-1). +C - nch. est un parametre entier indiquant s'il s'agit +C d'un minimum de meme degre que celui de la recherche +C en cours, ou bien d'une sortie de face. +C +C sorties : +C - peuvent etre modifies: imin, tabc, iback, ntback, +C tback, suivant le tableau ou a ete stocke le minimum tq +c +c +C! + implicit double precision (a-h,o-y) + dimension tq(0:*), tabc(mxsol,0:*), ntback(iback), + & tback(mxsol,0:*), xx(1),tg(ng+1),w(*) +C + common /sortie/ io,info,ll +C + ierr = 0 + if (nch .lt. -2) goto 200 + if (imin .eq. 0) goto 400 +C +C ---- test sur l'originalite du nouveau min ----------------------- +C +C ---- par rapport a tabc. +C + do 120 im = 1,imin +C + diff0 = 0.0d+0 + do 110 ij = 0,neq-1 + diff0 = diff0 + (tq(ij)-tabc(im,ij))**2 + 110 continue + diff0 = sqrt(diff0) +C + if (diff0 .lt. 1.0d-03) then + if (info .gt. 0) call outl2(80,0,0,xx,xx,x,x) + return + endif +C + 120 continue +C +C ---- par rapport a tback. +C +C - Situation des polynomes de meme degre. - +C + 200 if (nch.lt.0 .and. iback.gt.0) then + jsup = iback + 1 + jinf = 0 +C + do 210 j = iback,1,-1 + if (jsup.gt.j .and. ntback(j).gt.neq) jsup = j + 210 continue + do 220 j = 1,iback + if (jinf.lt.j .and. ntback(j).lt.neq) jinf = j + 220 continue +C +C - Controle de l'originalite. - +C + if ((jsup-jinf) .gt. 1) then +C + do 240 j = jinf+1,jsup-1 +C + diff0 = 0.0d+0 + do 230 i = 0,neq-1 + diff0 = diff0 + (tq(i)-tback(j,i))**2 + 230 continue + diff0 = sqrt(diff0) +C + if (diff0 .lt. 1.0d-03) then + if (info .gt. 0) call outl2(80,0,0,xx,xx,x,x) + return + endif +C + 240 continue + endif + endif +C +C -------- classement du nouveau minimum ----- +C ---- dans tback. +C + if (iback .eq. mxsol) then + ierr = 7 + return + endif + if (nch .lt. 0) then +C + if (iback .eq. 0) then +C + do 310 i = 0,neq-1 + tback(1,i) = tq(i) + 310 continue + ntback(1) = neq +C + elseif (jsup .gt. iback) then +C + do 330 i = 0,neq-1 + tback(jsup,i) = tq(i) + 330 continue + ntback(iback+1) = neq +C + + else +C + do 350 j = iback,jsup,-1 + do 340 i = 0,ntback(j)-1 + tback(j+1,i) = tback(j,i) + 340 continue + ntback(j+1) = ntback(j) + 350 continue +C + do 370 i = 0,neq-1 + tback(jsup,i) = tq(i) + 370 continue + ntback(jsup) = neq +C + + endif +C + iback = iback + 1 + if (info .gt. 1) call outl2(81,neq,neq,xx,xx,x,x) + return +C + endif +C +C -------- dans tabc. + 400 continue + if (imin .eq. mxsol) then + ierr = 7 + return + endif + paux = phi(tq,neq,tg,ng,w) +C + if (imin .eq. 0) then +C + do 410 ij = 0,neq-1 + tabc(1,ij) = tq(ij) + 410 continue + tabc(1,neq) = paux + imin = imin + 1 +C + + else +C + do 490 im = imin,1,-1 +C + if (paux.gt.tabc(im,neq) .and. im.eq.imin) then +C + do 420 ij = 0,neq-1 + tabc(imin+1,ij) = tq(ij) + 420 continue + tabc(imin+1,neq) = paux + imin = imin + 1 + return +C + elseif (paux .gt. tabc(im,neq)) then +C + do 440 in = imin,im+1,-1 + do 430 ij = 0,neq + tabc(in+1,ij) = tabc(in,ij) + 430 continue + 440 continue + do 450 ij = 0,neq-1 + tabc(im+1,ij) = tq(ij) + 450 continue + tabc(im+1,neq) = paux + imin = imin + 1 + return +C + elseif (im .eq. 1) then +C + do 470 in = imin,1,-1 + do 460 ij = 0,neq + tabc(in+1,ij) = tabc(in,ij) + 460 continue + 470 continue + do 480 ij = 0,neq-1 + tabc(1,ij) = tq(ij) + 480 continue + tabc(1,neq) = paux + imin = imin + 1 +C + endif +C + 490 continue +C + + endif +C + return + end + diff --git a/modules/cacsd/src/fortran/storl2.lo b/modules/cacsd/src/fortran/storl2.lo new file mode 100755 index 000000000..b8c0ae379 --- /dev/null +++ b/modules/cacsd/src/fortran/storl2.lo @@ -0,0 +1,12 @@ +# src/fortran/storl2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/storl2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/tild.f b/modules/cacsd/src/fortran/tild.f new file mode 100755 index 000000000..3fa744ce6 --- /dev/null +++ b/modules/cacsd/src/fortran/tild.f @@ -0,0 +1,33 @@ + + +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + +C/MEMBR ADD NAME=TILD,SSI=0 + + subroutine tild(n,tp,tpti) +c!but +c pour un polynome p(z) l'operation tild aboutit a un polynome +c ptild(z) defini par la relation suivante : +c ptild(z)= z**n * p(1/z) . +c!liste d'appel +c Entree : - tp . vecteur des coefficients du polynome a "tilder" . +c - n . degre du polynome "tp" +c +c Sortie : - tpti . vecteur des coefficients du polynome resultant . +c +c! + implicit double precision (a-h,o-y) + dimension tp(0:*),tpti(0:*) +c + do 50 j=0,n + tpti(j)=tp(n-j) + 50 continue + return + end diff --git a/modules/cacsd/src/fortran/tild.lo b/modules/cacsd/src/fortran/tild.lo new file mode 100755 index 000000000..cad1daf82 --- /dev/null +++ b/modules/cacsd/src/fortran/tild.lo @@ -0,0 +1,12 @@ +# src/fortran/tild.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/tild.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/watfac.f b/modules/cacsd/src/fortran/watfac.f new file mode 100755 index 000000000..bac5eb9dd --- /dev/null +++ b/modules/cacsd/src/fortran/watfac.f @@ -0,0 +1,76 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine watfac(nq,tq,nface,newrap,w) +c!but +c Cette procedure est charge de determiner quelle est +c la face franchie par la trajectoire du gradient. +c!liste d'appel +c subroutine watfac(nq,tq,nface,newrap,w) +c dimension tq(0:nq),w(3*nq+1) +c +c Entrees : +c - nq. est toujours le degre du polynome q(z) +c - tq. est le tableau des coefficients de ce polynome. +c +c Sortie : +c - nface contient l indice de la face que le chemin +c de la recherche a traverse. +c Les valeurs possibles de nface sont: 0 pour la face +c complexe, 1 pour la face 'z+1' et -1 pour la face 'z-1'. +c - newrap est un parametre indiquant s'il est necessaire +c ou pas d'effectuer un nouveau un rapprochement. +c +c Tableaux de travail +c - w : 3*nq+1 +c! + + implicit double precision (a-h,o-z) + dimension tq(nq+1),w(*) + logical fail +c + lpol=1 + lzr=lpol+nq+1 + lzi=lzr+nq + lzmod=lpol + lfree=lzi+nq +c + call dcopy(nq+1,tq,1,w(lpol),-1) + call rpoly(w(lpol),nq,w(lzr),w(lzi),fail) + call modul(nq,w(lzr),w(lzi),w(lzmod)) +c + nmod1=0 + do 110 j=1,nq + if (w(lzmod-1+j).ge.1.0d+0) then + nmod1=nmod1+1 + if(nmod1.eq.1) indi=j + endif + 110 continue +c + if (nmod1.eq.2) then + if(w(lzi-1+indi).eq.0.0d+0) then + newrap=1 + return + else + nface=0 + endif + endif +c + if (nmod1.eq.1) then + if (w(lzr-1+indi).gt.0.0d+0) then + nface=-1 + else + nface=1 + endif + endif +c + newrap=0 +c + return + end diff --git a/modules/cacsd/src/fortran/watfac.lo b/modules/cacsd/src/fortran/watfac.lo new file mode 100755 index 000000000..2fc9db60a --- /dev/null +++ b/modules/cacsd/src/fortran/watfac.lo @@ -0,0 +1,12 @@ +# src/fortran/watfac.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/watfac.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/wdegre.f b/modules/cacsd/src/fortran/wdegre.f new file mode 100755 index 000000000..657d69ce2 --- /dev/null +++ b/modules/cacsd/src/fortran/wdegre.f @@ -0,0 +1,30 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + +C/MEMBR ADD NAME=WDEGRE,SSI=0 + + subroutine wdegre(ar,ai,majo,nvrai) +c calcul du degre d un polynome a coefficients complexes +c a=ar+i*ai=coeffs par ordre croissant +c majo=majorant du degre +c nvrai=degre calcule + dimension ar(*),ai(*) + double precision ar,ai,test + if(majo.eq.0) goto 20 + do 10 k=1,majo+1 + kk=majo+2-k + test=abs(ar(kk))+abs(ai(kk)) + if(1.0d+0+test.ne.1.0d+0) then + nvrai=kk-1 + return + endif + 10 continue + 20 nvrai=0 + return + end diff --git a/modules/cacsd/src/fortran/wdegre.lo b/modules/cacsd/src/fortran/wdegre.lo new file mode 100755 index 000000000..949f022a4 --- /dev/null +++ b/modules/cacsd/src/fortran/wdegre.lo @@ -0,0 +1,12 @@ +# src/fortran/wdegre.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wdegre.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/fortran/wesidu.f b/modules/cacsd/src/fortran/wesidu.f new file mode 100755 index 000000000..3f7c2423c --- /dev/null +++ b/modules/cacsd/src/fortran/wesidu.f @@ -0,0 +1,135 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - F. Delebecque +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine wesidu(pr,pi,np,ar,ai,na,br,bi,nb,vr,vi,tol,ierr) +c calcul de la somme des residus de p/(a.b) +c aux zeros de a +c p=pr+i*pi=polynome de degre np a coefficients complexes +c a=ar+i*ai na +c b=br+i*bi nb +c les zeros de b sont supposes tous differents des +c zeros de a.... +c a,b et p dimensionnes au moins a leur degre+1 dans le pgm +c appelant. +c rangement par degres croissants. +c v=vr+i*vi=resultat +c principe du calcul:si a (ou b) est une constante on a +c v=p(nb)/b(nb+1)/a(1) +c sinon on remplace p et a par le reste de la division +c euclidienne de p et a par b,puis on inverse les roles +c de a et b en changeant le signe de v. +c on itere jusqu a trouver degre de a ou degre de b=0. + +c + + dimension ar(*),br(*),pr(*),ai(*),bi(*),pi(*) + double precision ar,br,pr,vr,rr,ai,bi,pi,vi,ri,tol,b1 + vr=0.0d+0 + vi=0.0d+0 + npp=np + call wdegre(ar,ai,na,na) + call wdegre(br,bi,nb,nb) + if(na.eq.0) return + if (nb.eq.0) then + b1=abs(br(1)+bi(1)) + if(b1.eq.0.0d+0) then + ierr=0 + return + endif + if(npp.ge.na-1) then + call wdiv(pr(na),pi(na),ar(na+1),ai(na+1),vr,vi) + call wdiv(vr,vi,br(1),bi(1),vr,vi) + return + else + vr=0.0d+0 + vi=0.0d+0 + return + endif + endif + if(na.gt.np) goto 11 +c p=p/a (reste de la division euclidienne...) + call wpodiv(pr,pi,ar,ai,np,na,ierr) + if(ierr.ne.0) then + return + endif + call wdegre(pr,pi,na-1,np) + 11 continue + if(na.gt.nb) goto 31 +c b=b/a (reste de la div euclidienne...) + call wpodiv(br,bi,ar,ai,nb,na,ierr) + if(ierr.ne.0) then + return + endif + call wdegre(br,bi,na-1,nb) + 31 continue + if(na.eq.1) then +c v=p(na)/a(na+1)/b(1) + b1=abs(br(1))+abs(bi(1)) + if(b1.le.tol) then + ierr=1 + return + endif + call wdiv(pr(na),pi(na),ar(na+1),ai(na+1),vr,vi) + call wdiv(vr,vi,br(1),bi(1),vr,vi) + return + endif + call wdegre(br,bi,min(na-1,nb),nb) + if(nb.gt.0) goto 32 + b1=abs(br(1))+abs(bi(1)) + if(b1.le.tol) then + ierr=1 + return + endif + if(npp.ge.na-1) then +c v=p(na)/a(na+1)/b(1) + call wdiv(pr(na),pi(na),ar(na+1),ai(na+1),vr,vi) + call wdiv(vr,vi,br(1),bi(1),vr,vi) + return + else + vr=0.0d+0 + vi=0.0d+0 + endif + 32 continue + nit=0 + 20 continue + if(nit.ge.1) na=nbb + nit=nit+1 + nbb=nb + call wpodiv(ar,ai,br,bi,na,nb,ierr) + if(ierr.ne.0) then + return + endif + call wdegre(ar,ai,nb-1,na) + call wpodiv(pr,pi,br,bi,np,nb,ierr) + if(ierr.ne.0) then + return + endif + call wdegre(pr,pi,nb-1,np) + do 30 k=1,nb+1 + rr=br(k) + ri=bi(k) + br(k)=-ar(k) + bi(k)=-ai(k) + ar(k)=rr + ai(k)=ri + 30 continue + call wdegre(br,bi,na,nb) + if(nb.eq.0) goto 99 + goto 20 + 99 continue +c v=p(nbb)/a(nbb+1)/b(1) + b1=abs(br(1))+abs(bi(1)) + if(b1.le.tol) then + ierr=1 + return + endif + call wdiv(pr(nbb),pi(nbb),ar(nbb+1),ai(nbb+1),vr,vi) + call wdiv(vr,vi,br(1),bi(1),vr,vi) + return + end diff --git a/modules/cacsd/src/fortran/wesidu.lo b/modules/cacsd/src/fortran/wesidu.lo new file mode 100755 index 000000000..686c64e8a --- /dev/null +++ b/modules/cacsd/src/fortran/wesidu.lo @@ -0,0 +1,12 @@ +# src/fortran/wesidu.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wesidu.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/.deps/.dirstamp b/modules/cacsd/src/slicot/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/cacsd/src/slicot/.deps/.dirstamp diff --git a/modules/cacsd/src/slicot/.dirstamp b/modules/cacsd/src/slicot/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/cacsd/src/slicot/.dirstamp diff --git a/modules/cacsd/src/slicot/.libs/Ex-schur.o b/modules/cacsd/src/slicot/.libs/Ex-schur.o Binary files differnew file mode 100755 index 000000000..185b62dd4 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/Ex-schur.o diff --git a/modules/cacsd/src/slicot/.libs/ZB03OD.o b/modules/cacsd/src/slicot/.libs/ZB03OD.o Binary files differnew file mode 100755 index 000000000..e12f08347 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ZB03OD.o diff --git a/modules/cacsd/src/slicot/.libs/ab01nd.o b/modules/cacsd/src/slicot/.libs/ab01nd.o Binary files differnew file mode 100755 index 000000000..be4670366 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ab01nd.o diff --git a/modules/cacsd/src/slicot/.libs/ab01od.o b/modules/cacsd/src/slicot/.libs/ab01od.o Binary files differnew file mode 100755 index 000000000..82cf827f5 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ab01od.o diff --git a/modules/cacsd/src/slicot/.libs/ab13md.o b/modules/cacsd/src/slicot/.libs/ab13md.o Binary files differnew file mode 100755 index 000000000..f773c1474 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ab13md.o diff --git a/modules/cacsd/src/slicot/.libs/ereduc.o b/modules/cacsd/src/slicot/.libs/ereduc.o Binary files differnew file mode 100755 index 000000000..8bc204b15 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ereduc.o diff --git a/modules/cacsd/src/slicot/.libs/fstair.o b/modules/cacsd/src/slicot/.libs/fstair.o Binary files differnew file mode 100755 index 000000000..cc1a48fdc --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/fstair.o diff --git a/modules/cacsd/src/slicot/.libs/ib01ad.o b/modules/cacsd/src/slicot/.libs/ib01ad.o Binary files differnew file mode 100755 index 000000000..1f189bdc4 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01ad.o diff --git a/modules/cacsd/src/slicot/.libs/ib01bd.o b/modules/cacsd/src/slicot/.libs/ib01bd.o Binary files differnew file mode 100755 index 000000000..face28a3f --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01bd.o diff --git a/modules/cacsd/src/slicot/.libs/ib01cd.o b/modules/cacsd/src/slicot/.libs/ib01cd.o Binary files differnew file mode 100755 index 000000000..c405931bc --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01cd.o diff --git a/modules/cacsd/src/slicot/.libs/ib01md.o b/modules/cacsd/src/slicot/.libs/ib01md.o Binary files differnew file mode 100755 index 000000000..953207194 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01md.o diff --git a/modules/cacsd/src/slicot/.libs/ib01my.o b/modules/cacsd/src/slicot/.libs/ib01my.o Binary files differnew file mode 100755 index 000000000..9e6343e59 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01my.o diff --git a/modules/cacsd/src/slicot/.libs/ib01nd.o b/modules/cacsd/src/slicot/.libs/ib01nd.o Binary files differnew file mode 100755 index 000000000..fffec417d --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01nd.o diff --git a/modules/cacsd/src/slicot/.libs/ib01od.o b/modules/cacsd/src/slicot/.libs/ib01od.o Binary files differnew file mode 100755 index 000000000..25f28e214 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01od.o diff --git a/modules/cacsd/src/slicot/.libs/ib01oy.o b/modules/cacsd/src/slicot/.libs/ib01oy.o Binary files differnew file mode 100755 index 000000000..6af593c51 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01oy.o diff --git a/modules/cacsd/src/slicot/.libs/ib01pd.o b/modules/cacsd/src/slicot/.libs/ib01pd.o Binary files differnew file mode 100755 index 000000000..4efbea716 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01pd.o diff --git a/modules/cacsd/src/slicot/.libs/ib01px.o b/modules/cacsd/src/slicot/.libs/ib01px.o Binary files differnew file mode 100755 index 000000000..352fe2086 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01px.o diff --git a/modules/cacsd/src/slicot/.libs/ib01py.o b/modules/cacsd/src/slicot/.libs/ib01py.o Binary files differnew file mode 100755 index 000000000..2bddae47c --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01py.o diff --git a/modules/cacsd/src/slicot/.libs/ib01qd.o b/modules/cacsd/src/slicot/.libs/ib01qd.o Binary files differnew file mode 100755 index 000000000..ec76e187b --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01qd.o diff --git a/modules/cacsd/src/slicot/.libs/ib01rd.o b/modules/cacsd/src/slicot/.libs/ib01rd.o Binary files differnew file mode 100755 index 000000000..c65a03181 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ib01rd.o diff --git a/modules/cacsd/src/slicot/.libs/inva.o b/modules/cacsd/src/slicot/.libs/inva.o Binary files differnew file mode 100755 index 000000000..13a125a8b --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/inva.o diff --git a/modules/cacsd/src/slicot/.libs/ma02ad.o b/modules/cacsd/src/slicot/.libs/ma02ad.o Binary files differnew file mode 100755 index 000000000..07ebc5380 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ma02ad.o diff --git a/modules/cacsd/src/slicot/.libs/ma02ed.o b/modules/cacsd/src/slicot/.libs/ma02ed.o Binary files differnew file mode 100755 index 000000000..e1aa0c9df --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ma02ed.o diff --git a/modules/cacsd/src/slicot/.libs/ma02fd.o b/modules/cacsd/src/slicot/.libs/ma02fd.o Binary files differnew file mode 100755 index 000000000..d4b6e629f --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ma02fd.o diff --git a/modules/cacsd/src/slicot/.libs/mb01pd.o b/modules/cacsd/src/slicot/.libs/mb01pd.o Binary files differnew file mode 100755 index 000000000..c06c6b5df --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb01pd.o diff --git a/modules/cacsd/src/slicot/.libs/mb01qd.o b/modules/cacsd/src/slicot/.libs/mb01qd.o Binary files differnew file mode 100755 index 000000000..42f1e50ba --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb01qd.o diff --git a/modules/cacsd/src/slicot/.libs/mb01rd.o b/modules/cacsd/src/slicot/.libs/mb01rd.o Binary files differnew file mode 100755 index 000000000..923785105 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb01rd.o diff --git a/modules/cacsd/src/slicot/.libs/mb01ru.o b/modules/cacsd/src/slicot/.libs/mb01ru.o Binary files differnew file mode 100755 index 000000000..b7fc2d7a7 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb01ru.o diff --git a/modules/cacsd/src/slicot/.libs/mb01rx.o b/modules/cacsd/src/slicot/.libs/mb01rx.o Binary files differnew file mode 100755 index 000000000..f854839e3 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb01rx.o diff --git a/modules/cacsd/src/slicot/.libs/mb01ry.o b/modules/cacsd/src/slicot/.libs/mb01ry.o Binary files differnew file mode 100755 index 000000000..7c85c949d --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb01ry.o diff --git a/modules/cacsd/src/slicot/.libs/mb01sd.o b/modules/cacsd/src/slicot/.libs/mb01sd.o Binary files differnew file mode 100755 index 000000000..b55de5621 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb01sd.o diff --git a/modules/cacsd/src/slicot/.libs/mb01td.o b/modules/cacsd/src/slicot/.libs/mb01td.o Binary files differnew file mode 100755 index 000000000..eabdbd947 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb01td.o diff --git a/modules/cacsd/src/slicot/.libs/mb01ud.o b/modules/cacsd/src/slicot/.libs/mb01ud.o Binary files differnew file mode 100755 index 000000000..24876f566 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb01ud.o diff --git a/modules/cacsd/src/slicot/.libs/mb01vd.o b/modules/cacsd/src/slicot/.libs/mb01vd.o Binary files differnew file mode 100755 index 000000000..9b2144f58 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb01vd.o diff --git a/modules/cacsd/src/slicot/.libs/mb02pd.o b/modules/cacsd/src/slicot/.libs/mb02pd.o Binary files differnew file mode 100755 index 000000000..949a4686c --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb02pd.o diff --git a/modules/cacsd/src/slicot/.libs/mb02qy.o b/modules/cacsd/src/slicot/.libs/mb02qy.o Binary files differnew file mode 100755 index 000000000..b205c3cad --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb02qy.o diff --git a/modules/cacsd/src/slicot/.libs/mb02ud.o b/modules/cacsd/src/slicot/.libs/mb02ud.o Binary files differnew file mode 100755 index 000000000..b9ff12db3 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb02ud.o diff --git a/modules/cacsd/src/slicot/.libs/mb03od.o b/modules/cacsd/src/slicot/.libs/mb03od.o Binary files differnew file mode 100755 index 000000000..9d2674d5f --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb03od.o diff --git a/modules/cacsd/src/slicot/.libs/mb03oy.o b/modules/cacsd/src/slicot/.libs/mb03oy.o Binary files differnew file mode 100755 index 000000000..49e1c0884 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb03oy.o diff --git a/modules/cacsd/src/slicot/.libs/mb03ud.o b/modules/cacsd/src/slicot/.libs/mb03ud.o Binary files differnew file mode 100755 index 000000000..f3d0ad34c --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb03ud.o diff --git a/modules/cacsd/src/slicot/.libs/mb04id.o b/modules/cacsd/src/slicot/.libs/mb04id.o Binary files differnew file mode 100755 index 000000000..0e094be32 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb04id.o diff --git a/modules/cacsd/src/slicot/.libs/mb04iy.o b/modules/cacsd/src/slicot/.libs/mb04iy.o Binary files differnew file mode 100755 index 000000000..84a971723 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb04iy.o diff --git a/modules/cacsd/src/slicot/.libs/mb04kd.o b/modules/cacsd/src/slicot/.libs/mb04kd.o Binary files differnew file mode 100755 index 000000000..314dc897a --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb04kd.o diff --git a/modules/cacsd/src/slicot/.libs/mb04nd.o b/modules/cacsd/src/slicot/.libs/mb04nd.o Binary files differnew file mode 100755 index 000000000..f2bb0a1aa --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb04nd.o diff --git a/modules/cacsd/src/slicot/.libs/mb04ny.o b/modules/cacsd/src/slicot/.libs/mb04ny.o Binary files differnew file mode 100755 index 000000000..b43f47302 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb04ny.o diff --git a/modules/cacsd/src/slicot/.libs/mb04od.o b/modules/cacsd/src/slicot/.libs/mb04od.o Binary files differnew file mode 100755 index 000000000..f4492825b --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb04od.o diff --git a/modules/cacsd/src/slicot/.libs/mb04oy.o b/modules/cacsd/src/slicot/.libs/mb04oy.o Binary files differnew file mode 100755 index 000000000..5b94222e2 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/mb04oy.o diff --git a/modules/cacsd/src/slicot/.libs/polmc.o b/modules/cacsd/src/slicot/.libs/polmc.o Binary files differnew file mode 100755 index 000000000..b668cf7f7 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/polmc.o diff --git a/modules/cacsd/src/slicot/.libs/riccpack.o b/modules/cacsd/src/slicot/.libs/riccpack.o Binary files differnew file mode 100755 index 000000000..2dc6d5b55 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/riccpack.o diff --git a/modules/cacsd/src/slicot/.libs/sb02mr.o b/modules/cacsd/src/slicot/.libs/sb02mr.o Binary files differnew file mode 100755 index 000000000..eb47d55ab --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02mr.o diff --git a/modules/cacsd/src/slicot/.libs/sb02ms.o b/modules/cacsd/src/slicot/.libs/sb02ms.o Binary files differnew file mode 100755 index 000000000..2c75aa6c1 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02ms.o diff --git a/modules/cacsd/src/slicot/.libs/sb02mt.o b/modules/cacsd/src/slicot/.libs/sb02mt.o Binary files differnew file mode 100755 index 000000000..9708b2c92 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02mt.o diff --git a/modules/cacsd/src/slicot/.libs/sb02nd.o b/modules/cacsd/src/slicot/.libs/sb02nd.o Binary files differnew file mode 100755 index 000000000..27b5344ce --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02nd.o diff --git a/modules/cacsd/src/slicot/.libs/sb02od.o b/modules/cacsd/src/slicot/.libs/sb02od.o Binary files differnew file mode 100755 index 000000000..4fc537720 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02od.o diff --git a/modules/cacsd/src/slicot/.libs/sb02ou.o b/modules/cacsd/src/slicot/.libs/sb02ou.o Binary files differnew file mode 100755 index 000000000..bcbc3265a --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02ou.o diff --git a/modules/cacsd/src/slicot/.libs/sb02ov.o b/modules/cacsd/src/slicot/.libs/sb02ov.o Binary files differnew file mode 100755 index 000000000..0f3a52be9 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02ov.o diff --git a/modules/cacsd/src/slicot/.libs/sb02oy.o b/modules/cacsd/src/slicot/.libs/sb02oy.o Binary files differnew file mode 100755 index 000000000..750ebf95e --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02oy.o diff --git a/modules/cacsd/src/slicot/.libs/sb02qd.o b/modules/cacsd/src/slicot/.libs/sb02qd.o Binary files differnew file mode 100755 index 000000000..fc8dac484 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02qd.o diff --git a/modules/cacsd/src/slicot/.libs/sb02rd.o b/modules/cacsd/src/slicot/.libs/sb02rd.o Binary files differnew file mode 100755 index 000000000..ea84593fc --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02rd.o diff --git a/modules/cacsd/src/slicot/.libs/sb02ru.o b/modules/cacsd/src/slicot/.libs/sb02ru.o Binary files differnew file mode 100755 index 000000000..25db2460a --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02ru.o diff --git a/modules/cacsd/src/slicot/.libs/sb02sd.o b/modules/cacsd/src/slicot/.libs/sb02sd.o Binary files differnew file mode 100755 index 000000000..735caf042 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb02sd.o diff --git a/modules/cacsd/src/slicot/.libs/sb03md.o b/modules/cacsd/src/slicot/.libs/sb03md.o Binary files differnew file mode 100755 index 000000000..14c92a77c --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03md.o diff --git a/modules/cacsd/src/slicot/.libs/sb03mv.o b/modules/cacsd/src/slicot/.libs/sb03mv.o Binary files differnew file mode 100755 index 000000000..8ece5abf6 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03mv.o diff --git a/modules/cacsd/src/slicot/.libs/sb03mw.o b/modules/cacsd/src/slicot/.libs/sb03mw.o Binary files differnew file mode 100755 index 000000000..bfe8afa69 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03mw.o diff --git a/modules/cacsd/src/slicot/.libs/sb03mx.o b/modules/cacsd/src/slicot/.libs/sb03mx.o Binary files differnew file mode 100755 index 000000000..7adb44598 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03mx.o diff --git a/modules/cacsd/src/slicot/.libs/sb03my.o b/modules/cacsd/src/slicot/.libs/sb03my.o Binary files differnew file mode 100755 index 000000000..fe7ea2a56 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03my.o diff --git a/modules/cacsd/src/slicot/.libs/sb03od.o b/modules/cacsd/src/slicot/.libs/sb03od.o Binary files differnew file mode 100755 index 000000000..d1758be56 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03od.o diff --git a/modules/cacsd/src/slicot/.libs/sb03or.o b/modules/cacsd/src/slicot/.libs/sb03or.o Binary files differnew file mode 100755 index 000000000..81d11240f --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03or.o diff --git a/modules/cacsd/src/slicot/.libs/sb03ot.o b/modules/cacsd/src/slicot/.libs/sb03ot.o Binary files differnew file mode 100755 index 000000000..4e4fe3b43 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03ot.o diff --git a/modules/cacsd/src/slicot/.libs/sb03ou.o b/modules/cacsd/src/slicot/.libs/sb03ou.o Binary files differnew file mode 100755 index 000000000..f193fb37f --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03ou.o diff --git a/modules/cacsd/src/slicot/.libs/sb03ov.o b/modules/cacsd/src/slicot/.libs/sb03ov.o Binary files differnew file mode 100755 index 000000000..017673158 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03ov.o diff --git a/modules/cacsd/src/slicot/.libs/sb03oy.o b/modules/cacsd/src/slicot/.libs/sb03oy.o Binary files differnew file mode 100755 index 000000000..f07434334 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03oy.o diff --git a/modules/cacsd/src/slicot/.libs/sb03qx.o b/modules/cacsd/src/slicot/.libs/sb03qx.o Binary files differnew file mode 100755 index 000000000..7e813fa77 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03qx.o diff --git a/modules/cacsd/src/slicot/.libs/sb03qy.o b/modules/cacsd/src/slicot/.libs/sb03qy.o Binary files differnew file mode 100755 index 000000000..b6f6483bf --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03qy.o diff --git a/modules/cacsd/src/slicot/.libs/sb03sx.o b/modules/cacsd/src/slicot/.libs/sb03sx.o Binary files differnew file mode 100755 index 000000000..0d9b321ff --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03sx.o diff --git a/modules/cacsd/src/slicot/.libs/sb03sy.o b/modules/cacsd/src/slicot/.libs/sb03sy.o Binary files differnew file mode 100755 index 000000000..ba2c1a01d --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb03sy.o diff --git a/modules/cacsd/src/slicot/.libs/sb04md.o b/modules/cacsd/src/slicot/.libs/sb04md.o Binary files differnew file mode 100755 index 000000000..7f679423c --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04md.o diff --git a/modules/cacsd/src/slicot/.libs/sb04mr.o b/modules/cacsd/src/slicot/.libs/sb04mr.o Binary files differnew file mode 100755 index 000000000..72256e1aa --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04mr.o diff --git a/modules/cacsd/src/slicot/.libs/sb04mu.o b/modules/cacsd/src/slicot/.libs/sb04mu.o Binary files differnew file mode 100755 index 000000000..59ecab46b --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04mu.o diff --git a/modules/cacsd/src/slicot/.libs/sb04mw.o b/modules/cacsd/src/slicot/.libs/sb04mw.o Binary files differnew file mode 100755 index 000000000..c03dc5687 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04mw.o diff --git a/modules/cacsd/src/slicot/.libs/sb04my.o b/modules/cacsd/src/slicot/.libs/sb04my.o Binary files differnew file mode 100755 index 000000000..fc45e12f8 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04my.o diff --git a/modules/cacsd/src/slicot/.libs/sb04nd.o b/modules/cacsd/src/slicot/.libs/sb04nd.o Binary files differnew file mode 100755 index 000000000..21557c9ca --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04nd.o diff --git a/modules/cacsd/src/slicot/.libs/sb04nv.o b/modules/cacsd/src/slicot/.libs/sb04nv.o Binary files differnew file mode 100755 index 000000000..bef175b7f --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04nv.o diff --git a/modules/cacsd/src/slicot/.libs/sb04nw.o b/modules/cacsd/src/slicot/.libs/sb04nw.o Binary files differnew file mode 100755 index 000000000..cb3750091 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04nw.o diff --git a/modules/cacsd/src/slicot/.libs/sb04nx.o b/modules/cacsd/src/slicot/.libs/sb04nx.o Binary files differnew file mode 100755 index 000000000..088969662 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04nx.o diff --git a/modules/cacsd/src/slicot/.libs/sb04ny.o b/modules/cacsd/src/slicot/.libs/sb04ny.o Binary files differnew file mode 100755 index 000000000..a54882407 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04ny.o diff --git a/modules/cacsd/src/slicot/.libs/sb04pd.o b/modules/cacsd/src/slicot/.libs/sb04pd.o Binary files differnew file mode 100755 index 000000000..bfb043eb7 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04pd.o diff --git a/modules/cacsd/src/slicot/.libs/sb04px.o b/modules/cacsd/src/slicot/.libs/sb04px.o Binary files differnew file mode 100755 index 000000000..123e3ad8c --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04px.o diff --git a/modules/cacsd/src/slicot/.libs/sb04py.o b/modules/cacsd/src/slicot/.libs/sb04py.o Binary files differnew file mode 100755 index 000000000..a7eec9261 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04py.o diff --git a/modules/cacsd/src/slicot/.libs/sb04qd.o b/modules/cacsd/src/slicot/.libs/sb04qd.o Binary files differnew file mode 100755 index 000000000..ec8d8ba63 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04qd.o diff --git a/modules/cacsd/src/slicot/.libs/sb04qr.o b/modules/cacsd/src/slicot/.libs/sb04qr.o Binary files differnew file mode 100755 index 000000000..48e883d7d --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04qr.o diff --git a/modules/cacsd/src/slicot/.libs/sb04qu.o b/modules/cacsd/src/slicot/.libs/sb04qu.o Binary files differnew file mode 100755 index 000000000..03a093079 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04qu.o diff --git a/modules/cacsd/src/slicot/.libs/sb04qy.o b/modules/cacsd/src/slicot/.libs/sb04qy.o Binary files differnew file mode 100755 index 000000000..7cc1eae90 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04qy.o diff --git a/modules/cacsd/src/slicot/.libs/sb04rd.o b/modules/cacsd/src/slicot/.libs/sb04rd.o Binary files differnew file mode 100755 index 000000000..7e989b10d --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04rd.o diff --git a/modules/cacsd/src/slicot/.libs/sb04rv.o b/modules/cacsd/src/slicot/.libs/sb04rv.o Binary files differnew file mode 100755 index 000000000..4c3dfff37 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04rv.o diff --git a/modules/cacsd/src/slicot/.libs/sb04rw.o b/modules/cacsd/src/slicot/.libs/sb04rw.o Binary files differnew file mode 100755 index 000000000..15b0e532b --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04rw.o diff --git a/modules/cacsd/src/slicot/.libs/sb04rx.o b/modules/cacsd/src/slicot/.libs/sb04rx.o Binary files differnew file mode 100755 index 000000000..badaa9e46 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04rx.o diff --git a/modules/cacsd/src/slicot/.libs/sb04ry.o b/modules/cacsd/src/slicot/.libs/sb04ry.o Binary files differnew file mode 100755 index 000000000..2962d5ef4 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb04ry.o diff --git a/modules/cacsd/src/slicot/.libs/sb10dd.o b/modules/cacsd/src/slicot/.libs/sb10dd.o Binary files differnew file mode 100755 index 000000000..6681f5a1c --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb10dd.o diff --git a/modules/cacsd/src/slicot/.libs/sb10fd.o b/modules/cacsd/src/slicot/.libs/sb10fd.o Binary files differnew file mode 100755 index 000000000..4a95f9140 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb10fd.o diff --git a/modules/cacsd/src/slicot/.libs/sb10pd.o b/modules/cacsd/src/slicot/.libs/sb10pd.o Binary files differnew file mode 100755 index 000000000..964f01466 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb10pd.o diff --git a/modules/cacsd/src/slicot/.libs/sb10qd.o b/modules/cacsd/src/slicot/.libs/sb10qd.o Binary files differnew file mode 100755 index 000000000..74a6ff91b --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb10qd.o diff --git a/modules/cacsd/src/slicot/.libs/sb10rd.o b/modules/cacsd/src/slicot/.libs/sb10rd.o Binary files differnew file mode 100755 index 000000000..50919603b --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/sb10rd.o diff --git a/modules/cacsd/src/slicot/.libs/select.o b/modules/cacsd/src/slicot/.libs/select.o Binary files differnew file mode 100755 index 000000000..e8b804107 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/select.o diff --git a/modules/cacsd/src/slicot/.libs/ssxmc.o b/modules/cacsd/src/slicot/.libs/ssxmc.o Binary files differnew file mode 100755 index 000000000..680a3086d --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/ssxmc.o diff --git a/modules/cacsd/src/slicot/.libs/tb01wd.o b/modules/cacsd/src/slicot/.libs/tb01wd.o Binary files differnew file mode 100755 index 000000000..b5fec7b73 --- /dev/null +++ b/modules/cacsd/src/slicot/.libs/tb01wd.o diff --git a/modules/cacsd/src/slicot/Ex-schur.f b/modules/cacsd/src/slicot/Ex-schur.f new file mode 100755 index 000000000..01f9c7261 --- /dev/null +++ b/modules/cacsd/src/slicot/Ex-schur.f @@ -0,0 +1,503 @@ + + LOGICAL FUNCTION SB02MV( REIG, IEIG ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To select the stable eigenvalues +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 .. 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 + + + LOGICAL FUNCTION SB02MW( REIG, IEIG ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To select the stable eigenvalues for discrete-time +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 .. 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 + + LOGICAL FUNCTION SB02OW( ALPHAR, ALPHAI, BETA ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To select the stable generalized eigenvalues for continuous-time +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 ****************************************************************** +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 )) .AND. + $ abs(BETA).GT. abs(ALPHAR)*dlamch('p') +C + RETURN +C *** Last line of SB02OW *** + END + + + + LOGICAL FUNCTION SB02OX( ALPHAR, ALPHAI, BETA ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To select the stable generalized eigenvalues for +C discrete-time +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 ****************************************************************** +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 + + + LOGICAL FUNCTION ZB02MV( EIG ) +C +C RELEASE 4.0, WGS COPYRIGHT 2001. +C +C PURPOSE +C +C To select the stable eigenvalues in ordering the Schur form +C of a matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C EIG (input) COMPLEX*16 +C The current eigenvalue considered. +C +C METHOD +C +C The function value ZB02MV 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 +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 .. + COMPLEX*16 EIG +C .. Intrinsic Functions .. + INTRINSIC DREAL +C .. Executable Statements .. +C + ZB02MV = DREAL(EIG).LT.ZERO +C + RETURN +C *** Last line of ZB02MV *** + END + + LOGICAL FUNCTION ZB02MW( EIG ) +C +C RELEASE 4.0, WGS COPYRIGHT 2001. +C +C PURPOSE +C +C To select the eigenvalues inside the unit circle in ordering +C the Schur form of a matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C EIG (input) COMPLEX*16 +C The current eigenvalue considered. +C +C METHOD +C +C The function value ZB02MW is set to .TRUE. for an eigenvalue which +C is inside the unit circle and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C +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 ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + COMPLEX*16 EIG +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + ZB02MW = ABS(EIG).LT.ONE +C + RETURN +C *** Last line of ZB02MW *** + END + + + + LOGICAL FUNCTION ZB02OW( ALPHA, BETA ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To select the stable generalized eigenvalues for the +C continuous-time. +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 ZB02OW 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 +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 .. + COMPLEX*16 ALPHA, BETA + INTRINSIC DREAL +C .. Executable Statements .. +C + if (abs(BETA).ne.ZERO) then + ZB02OW = DREAL(ALPHA/BETA).LT.ZERO + else + ZB02OW = .FALSE. + endif +C + RETURN +C *** Last line of zb02ow *** + END + + + LOGICAL FUNCTION ZB02OX( ALPHA, BETA ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To select the stable generalized eigenvalues for the +C discrete-time algebraic. +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 ZB02OX 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 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 .. Scalar Arguments .. + COMPLEX*16 ALPHA, BETA +C .. External Functions .. +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + ZB02OX = ABS( ALPHA ).LT.ABS( BETA ) +C + RETURN +C *** Last line of ZB02OX *** + END + + + + + + + diff --git a/modules/cacsd/src/slicot/Ex-schur.lo b/modules/cacsd/src/slicot/Ex-schur.lo new file mode 100755 index 000000000..05a47ebb7 --- /dev/null +++ b/modules/cacsd/src/slicot/Ex-schur.lo @@ -0,0 +1,12 @@ +# src/slicot/Ex-schur.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/Ex-schur.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ZB03OD.f b/modules/cacsd/src/slicot/ZB03OD.f new file mode 100755 index 000000000..f987cf838 --- /dev/null +++ b/modules/cacsd/src/slicot/ZB03OD.f @@ -0,0 +1,290 @@ + + SUBROUTINE ZB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, + $ RANK, SVAL, WORK, LWORK, RWORK, INFO ) +* +* .. Scalar Arguments .. + CHARACTER*1 JOBQR + INTEGER INFO, LDA, LWORK, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION SVAL(3), RWORK( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +C +C RELEASE 4.0, WGS COPYRIGHT 2001. +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 ZB03OD does not perform any scaling of the matrix A. +* +* Arguments +* ========= +* +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 ssumes +C that it has been done outside). +* +* 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 M-by-N matrix A. +* On exit, A has been overwritten by details of its +* complete orthogonal factorization. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,M,N). +* +* JPVT (input/output) INTEGER array, dimension (N) +* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted +* to the front of AP, otherwise column i is a free column. +* On exit, if JPVT(i) = k, then the i-th column of A*P +* was the k-th column of A. +* +* 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 < 1/RCOND. +* +C +C TAU (output) COMPLEX*16 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 +* 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. +* +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 +* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* +* If JOBQR = 'Q': +* The unblocked strategy requires that: +* LWORK >= MAX( 2*MN, N+1 ) +* where MN = min(M,N). +* The block algorithm requires that: +* LWORK >= MAX( 2*MN, NB*(N+1) ) +* where NB is an upper bound on the blocksize returned +* by ILAENV for the routines ZGEQP3 and ZUNMQR. +* +* LDWORK = max( 1, 2*min( M, N ) ), if JOBQR = '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. +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +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 Complex version of MB03OD +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 ) ) +* .. +* .. Local Scalars .. + LOGICAL LJOBQR, LQUERY + INTEGER I, ISMAX, ISMIN, LWKOPT, MN, + $ NB, NB1, NB2 + DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR + COMPLEX*16 C1, C2, S1, S2 +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEQP3, ZLAIC1 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* + LJOBQR = LSAME( JOBQR, 'Q' ) + MN = MIN( M, N ) + ISMIN = 1 + ISMAX = MN + 1 +* +* Test the input arguments. +* + INFO = 0 + NB1 = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + NB2 = ILAENV( 1, 'ZUNMQR', ' ', M, N, NRHS, -1 ) + NB = MAX( NB1, NB2 ) + LWKOPT = MAX( 1, 2*N+NB*( N+1 ) ) + WORK( 1 ) = DCMPLX( LWKOPT ) + LQUERY = ( LWORK.EQ.-1 ) +C + 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( LWORK.LT.( MAX( 2*MN, N+1 ) ) .AND. .NOT. + $ LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZB03OD', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( MN.EQ.0 ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RANK = 0 + RETURN + END IF +C + IF( LJOBQR ) THEN +* +* Compute QR factorization with column pivoting of A: +* A * P = Q * R +* + CALL ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, + $ RWORK, INFO ) +* +* complex workspace: MN+NB*(N+1). real workspace 2*N. +* Details of Householder rotations stored in WORK(1:MN). + END IF +* +* Determine RANK using incremental condition estimation +* + WORK( ISMIN ) = CONE + WORK( ISMAX ) = CONE + 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 +* + 10 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 + CALL ZLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL ZLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) +* + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN + DO 20 I = 1, RANK + WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 ) + WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) + 20 CONTINUE + WORK( ISMIN+RANK ) = C1 + WORK( 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 + WORK( 1 ) = DCMPLX( LWKOPT ) +C + RETURN +C *** Last line of ZB03OD *** + END + diff --git a/modules/cacsd/src/slicot/ZB03OD.lo b/modules/cacsd/src/slicot/ZB03OD.lo new file mode 100755 index 000000000..e28d91b9b --- /dev/null +++ b/modules/cacsd/src/slicot/ZB03OD.lo @@ -0,0 +1,12 @@ +# src/slicot/ZB03OD.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ZB03OD.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ab01nd.f b/modules/cacsd/src/slicot/ab01nd.f new file mode 100755 index 000000000..ace8ac539 --- /dev/null +++ b/modules/cacsd/src/slicot/ab01nd.f @@ -0,0 +1,445 @@ + SUBROUTINE AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON, + $ NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK, + $ INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 +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*1 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( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. + $ LJOBZ .AND. LDZ.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF(TOL.LT.ZERO .OR. TOL.GT.ONE ) THEN +C added by S. STEER (see mb03oy) + INFO = -14 + 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 ) + $ RETURN +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 + 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 + CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) +C +C Annihilate the trailing elements of TAU, if JOBZ = 'F'. +C + IF ( LJOBF ) THEN + DO 30 J = ITAU, N + TAU(J) = ZERO + 30 CONTINUE + END IF +C +C Undo scaling of A and B. +C + IF ( INDCON.LT.N ) THEN + NBL = INDCON + 1 + NBLK(NBL) = N - NCONT + ELSE + NBL = 0 + END IF + CALL MB01PD( 'Undo', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, + $ LDA, INFO ) + CALL MB01PD( 'Undo', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, + $ LDB, INFO ) +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB01ND *** + END diff --git a/modules/cacsd/src/slicot/ab01nd.lo b/modules/cacsd/src/slicot/ab01nd.lo new file mode 100755 index 000000000..62e492e60 --- /dev/null +++ b/modules/cacsd/src/slicot/ab01nd.lo @@ -0,0 +1,12 @@ +# src/slicot/ab01nd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ab01nd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ab01od.f b/modules/cacsd/src/slicot/ab01od.f new file mode 100755 index 000000000..1b0b5b57b --- /dev/null +++ b/modules/cacsd/src/slicot/ab01od.f @@ -0,0 +1,512 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +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. +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*1 JOBU, JOBV, STAGES + INTEGER INFO, INDCON, 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( .NOT.LJOBUI .AND. LDU.LT.1 .OR. + $ LJOBUI .AND. LDU.LT.MAX( 1, 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( LSTGAB ) THEN + IF( .NOT.LJOBVI .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LJOBVI .AND. LDV.LT.1 .OR. + $ LJOBVI .AND. LDV.LT.MAX( 1, M ) ) THEN + INFO = -13 + END IF + ELSE IF( .NOT.LSTAGB .AND. (TOL.LT.ZERO .OR. TOL.GT.ONE) ) THEN +C added by S. STEER (see mb03oy) + INFO = -17 + 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 + 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 ) + IF(INFO.LT.0) RETURN +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 + RETURN + ELSE IF ( NCONT.EQ.0 .OR. INDCON.EQ.0 ) THEN + IF( LJOBVI ) + $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) + RETURN + END IF +C +C Now perform the backward steps except the last one. +C + MCRT = KSTAIR(INDCON) + I0 = NCONT - MCRT + 1 + JWORK = M + 1 +C + DO 10 IBSTEP = INDCON, 2, -1 + NCRT = KSTAIR(IBSTEP-1) + J0 = I0 - NCRT + MM = MIN( NCRT, MCRT ) +C +C Compute the RQ factorization of the current subdiagonal block +C of A, Ai,i-1 = R*Q (where i is IBSTEP), of dimension +C MCRT-by-NCRT, starting in position (I0,J0). +C The matrix Q' should postmultiply U, if required. +C Workspace: need M + MCRT; +C prefer M + MCRT*NB. +C + CALL DGERQF( MCRT, NCRT, A(I0,J0), LDA, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Set JINI to the first column number in A where the current +C transformation Q is to be applied, taking the block Hessenberg +C form into account. +C + IF ( IBSTEP.GT.2 ) THEN + JINI = J0 - KSTAIR(IBSTEP-2) + ELSE + JINI = 1 +C +C Premultiply the first block row (B1) of B by Q. +C Workspace: need 2*M; +C prefer M + M*NB. +C + CALL DORMRQ( 'Left', 'No transpose', NCRT, M, MM, A(I0,J0), + $ LDA, DWORK(ITAU), B, LDB, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + END IF +C +C Premultiply the appropriate block row of A by Q. +C Workspace: need M + N; +C prefer M + N*NB. +C + CALL DORMRQ( 'Left', 'No transpose', NCRT, N-JINI+1, MM, + $ A(I0,J0), LDA, DWORK(ITAU), A(J0,JINI), LDA, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Postmultiply the appropriate block column of A by Q'. +C Workspace: need M + I0-1; +C prefer M + (I0-1)*NB. +C + CALL DORMRQ( 'Right', 'Transpose', I0-1, NCRT, MM, A(I0,J0), + $ LDA, DWORK(ITAU), A(1,J0), LDA, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LJOBUI ) THEN +C +C Update U, postmultiplying it by Q'. +C Workspace: need M + N; +C prefer M + N*NB. +C + CALL DORMRQ( 'Right', 'Transpose', N, NCRT, MM, A(I0,J0), + $ LDA, DWORK(ITAU), U(1,J0), LDU, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + END IF +C +C Zero the subdiagonal elements of the current subdiagonal block +C of A. +C + CALL DLASET( 'F', MCRT, NCRT-MCRT, ZERO, ZERO, A(I0,J0), LDA ) + IF ( I0.LT.N ) + $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, + $ A(I0+1,I0-MCRT), LDA ) +C + MCRT = NCRT + I0 = J0 +C + 10 CONTINUE +C +C Now perform the last backward step on B, V = Qb'. +C +C Compute the RQ factorization of the first block of B, B1 = R*Qb. +C Workspace: need M + MCRT; +C prefer M + MCRT*NB. +C + CALL DGERQF( MCRT, M, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LJOBVI ) THEN +C +C Accumulate the input-space transformations V. +C Workspace: need 2*M; prefer M + M*NB. +C + CALL DLACPY( 'F', MCRT, M-MCRT, B, LDB, V(M-MCRT+1,1), LDV ) + IF ( MCRT.GT.1 ) + $ CALL DLACPY( 'L', MCRT-1, MCRT-1, B(2,M-MCRT+1), LDB, + $ V(M-MCRT+2,M-MCRT+1), LDV ) + CALL DORGRQ( M, M, MCRT, V, LDV, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C + DO 20 I = 2, M + CALL DSWAP( I-1, V(I, 1), LDV, V(1,I), 1 ) + 20 CONTINUE +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + END IF +C +C Zero the subdiagonal elements of the submatrix B1. +C + CALL DLASET( 'F', MCRT, M-MCRT, ZERO, ZERO, B, LDB ) + IF ( MCRT.GT.1 ) + $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, B(2,M-MCRT+1), + $ LDB ) +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB01OD *** + END diff --git a/modules/cacsd/src/slicot/ab01od.lo b/modules/cacsd/src/slicot/ab01od.lo new file mode 100755 index 000000000..e31d61218 --- /dev/null +++ b/modules/cacsd/src/slicot/ab01od.lo @@ -0,0 +1,12 @@ +# src/slicot/ab01od.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ab01od.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ab13md.f b/modules/cacsd/src/slicot/ab13md.f new file mode 100755 index 000000000..78093ebb0 --- /dev/null +++ b/modules/cacsd/src/slicot/ab13md.f @@ -0,0 +1,1766 @@ + SUBROUTINE AB13MD( FACT, N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D, + $ G, IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +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, SELECT, XFACT +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions + DOUBLE PRECISION DDOT, DLAMCH, DLANGE, ZLANGE + LOGICAL LSAME + EXTERNAL DDOT, DLAMCH, DLANGE, LSAME, 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 cummulative sums of blocks dimensions. +C + IWORK( 1 ) = 0 + DO 20 I = 2, M+1 + IWORK( I ) = IWORK( I - 1 ) + NBLOCK( I - 1 ) + 20 CONTINUE +C +C Find Osborne scaling if initial scaling is not given. +C + IF( .NOT.XFACT ) THEN + CALL DLASET( 'Full', M, M, ZERO, ZERO, DWORK, M ) + CALL DLASET( 'Full', M, 1, ONE, ONE, DWORK( IW2+1 ), M ) + ZNORM = ZLANGE( 'F', N, N, ZWORK, N, DWORK ) + DO 40 J = 1, M + DO 30 I = 1, M + IF( I.NE.J ) THEN + CALL ZLACPY( 'Full', IWORK( I+1 )-IWORK( I ), + $ IWORK( J+1 )-IWORK( J ), + $ Z( IWORK( I )+1, IWORK( J )+1 ), LDZ, + $ ZWORK( IZ2+1 ), N ) + CALL ZGESVD( 'N', 'N', IWORK( I+1 )-IWORK( I ), + $ IWORK( J+1 )-IWORK( J ), ZWORK( IZ2+1 ), + $ N, DWORK( IW3+1 ), ZWORK, 1, ZWORK, 1, + $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, + $ DWORK( IWRK+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + ZNORM2 = DWORK( IW3+1 ) + DWORK( I+(J-1)*M ) = ZNORM2 + ZNORM*TOL2 + END IF + 30 CONTINUE + 40 CONTINUE + CALL DLASET( 'Full', M, 1, ZERO, ZERO, DWORK( IW4+1 ), M ) + 50 DO 60 I = 1, M + DWORK( IW5+I ) = DWORK( IW4+I ) - ONE + 60 CONTINUE + HNORM = DLANGE( 'F', M, 1, DWORK( IW5+1 ), M, DWORK ) + IF( HNORM.LE.TOL2 ) GO TO 120 + DO 110 K = 1, M + COLSUM = ZERO + DO 70 I = 1, M + COLSUM = COLSUM + DWORK( I+(K-1)*M ) + 70 CONTINUE + ROWSUM = ZERO + DO 80 J = 1, M + ROWSUM = ROWSUM + DWORK( K+(J-1)*M ) + 80 CONTINUE + RAT = SQRT( COLSUM / ROWSUM ) + DWORK( IW4+K ) = RAT + DO 90 I = 1, M + DWORK( I+(K-1)*M ) = DWORK( I+(K-1)*M ) / RAT + 90 CONTINUE + DO 100 J = 1, M + DWORK( K+(J-1)*M ) = DWORK( K+(J-1)*M )*RAT + 100 CONTINUE + DWORK( IW2+K ) = DWORK( IW2+K )*RAT + 110 CONTINUE + GO TO 50 + 120 SCALE = ONE / DWORK( IW2+1 ) + CALL DSCAL( M, SCALE, DWORK( IW2+1 ), 1 ) + ELSE + DWORK( IW2+1 ) = ONE + DO 130 I = 2, M + DWORK( IW2+I ) = SQRT( X( I-1 ) ) + 130 CONTINUE + END IF + DO 150 J = 1, M + DO 140 I = 1, M + IF( I.NE.J ) THEN + CALL ZLASCL( 'G', M, M, DWORK( IW2+J ), DWORK( IW2+I ), + $ IWORK( I+1 )-IWORK( I ), + $ IWORK( J+1 )-IWORK( J ), + $ ZWORK( IWORK( I )+1+IWORK( J )*N ), N, + $ INFO2 ) + END IF + 140 CONTINUE + 150 CONTINUE +C +C Scale Z by its 2-norm. +C + CALL ZLACPY( 'Full', N, N, ZWORK, N, ZWORK( IZ2+1 ), N ) + CALL ZGESVD( 'N', 'N', N, N, ZWORK( IZ2+1 ), N, DWORK( IW3+1 ), + $ ZWORK, 1, ZWORK, 1, ZWORK( IZWRK+1 ), LZWORK-IZWRK, + $ DWORK( IWRK+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + ZNORM = DWORK( IW3+1 ) + CALL ZLASCL( 'G', M, M, ZNORM, ONE, N, N, ZWORK, N, INFO2 ) +C +C Set BB. +C + CALL DLASET( 'Full', N*N, MT, ZERO, ZERO, DWORK( IW9+1 ), N*N ) +C +C Set P. +C + DO 160 I = 1, NBLOCK( 1 ) + DWORK( IW6+I ) = ONE + 160 CONTINUE + DO 170 I = NBLOCK( 1 )+1, N + DWORK( IW6+I ) = ZERO + 170 CONTINUE +C +C Compute P*Z. +C + DO 190 J = 1, N + DO 180 I = 1, N + ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* + $ ZWORK( I+(J-1)*N ) + 180 CONTINUE + 190 CONTINUE +C +C Compute Z'*P*Z. +C + CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), N, + $ CZERO, ZWORK( IZ4+1 ), N ) +C +C Copy Z'*P*Z into A0. +C + CALL ZLACPY( 'Full', N, N, ZWORK( IZ4+1 ), N, ZWORK( IZ5+1 ), N ) +C +C Copy diag(P) into B0d. +C + CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW7+1 ), 1 ) +C + DO 270 K = 2, M +C +C Set P. +C + DO 200 I = 1, IWORK( K ) + DWORK( IW6+I ) = ZERO + 200 CONTINUE + DO 210 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) + DWORK( IW6+I ) = ONE + 210 CONTINUE + IF( K.LT.M ) THEN + DO 220 I = IWORK( K+1 )+1, N + DWORK( IW6+I ) = ZERO + 220 CONTINUE + END IF +C +C Compute P*Z. +C + DO 240 J = 1, N + DO 230 I = 1, N + ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* + $ ZWORK( I+(J-1)*N ) + 230 CONTINUE + 240 CONTINUE +C +C Compute t = Z'*P*Z. +C + CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), + $ N, CZERO, ZWORK( IZ4+1 ), N ) +C +C Copy t(:) into the (k-1)-th column of AA. +C + CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, ZWORK( IZ6+1+(K-2)*N*N ), + $ 1 ) +C +C Copy diag(P) into the (k-1)-th column of BBd. +C + CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW8+1+(K-2)*N ), 1 ) +C +C Copy P(:) into the (k-1)-th column of BB. +C + DO 260 I = 1, N + DWORK( IW9+I+(I-1)*N+(K-2)*N*N ) = DWORK( IW6+I ) + 260 CONTINUE + 270 CONTINUE +C + L = 0 +C + DO 350 K = 1, M + IF( ITYPE( K ).EQ.1 ) THEN + L = L + 1 +C +C Set P. +C + DO 280 I = 1, IWORK( K ) + DWORK( IW6+I ) = ZERO + 280 CONTINUE + DO 290 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) + DWORK( IW6+I ) = ONE + 290 CONTINUE + IF( K.LT.M ) THEN + DO 300 I = IWORK( K+1 )+1, N + DWORK( IW6+I ) = ZERO + 300 CONTINUE + END IF +C +C Compute P*Z. +C + DO 320 J = 1, N + DO 310 I = 1, N + ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* + $ ZWORK( I+(J-1)*N ) + 310 CONTINUE + 320 CONTINUE +C +C Compute t = sqrt(-1)*( P*Z - Z'*P ). +C + DO 340 J = 1, N + DO 330 I = 1, J + TEMPIJ = ZWORK( IZ3+I+(J-1)*N ) + TEMPJI = ZWORK( IZ3+J+(I-1)*N ) + ZWORK( IZ4+I+(J-1)*N ) = CIMAG*( TEMPIJ - + $ DCONJG( TEMPJI ) ) + ZWORK( IZ4+J+(I-1)*N ) = CIMAG*( TEMPJI - + $ DCONJG( TEMPIJ ) ) + 330 CONTINUE + 340 CONTINUE +C +C Copy t(:) into the (m-1+l)-th column of AA. +C + CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, + $ ZWORK( IZ6+1+(M-2+L)*N*N ), 1 ) + END IF + 350 CONTINUE +C +C Set initial X. +C + DO 360 I = 1, M - 1 + X( I ) = ONE + 360 CONTINUE + IF( MR.GT.0 ) THEN + IF( .NOT.XFACT ) THEN + DO 370 I = 1, MR + X( M-1+I ) = ZERO + 370 CONTINUE + ELSE + L = 0 + DO 380 K = 1, M + IF( ITYPE( K ).EQ.1 ) THEN + L = L + 1 + X( M-1+L ) = X( M-1+L ) / DWORK( IW2+K )**2 + END IF + 380 CONTINUE + END IF + END IF +C +C Set constants. +C + SVLAM = ONE / EPS + C = ONE +C +C Set H. +C + CALL DLASET( 'Full', MT, MT, ZERO, ONE, DWORK( IW11+1 ), MT ) +C + ITER = -1 +C +C Main iteration loop. +C + 390 ITER = ITER + 1 +C +C Compute A(:) = A0 + AA*x. +C + DO 400 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 400 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( Binv ). +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW12+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, + $ DWORK( IW12+1 ), 1 ) + DO 410 I = 1, N + DWORK( IW12+I ) = ONE / DWORK( IW12+I ) + 410 CONTINUE +C +C Compute Binv*A. +C + DO 430 J = 1, N + DO 420 I = 1, N + ZWORK( IZ11+I+(J-1)*N ) = DCMPLX( DWORK( IW12+I ) )* + $ ZWORK( IZ7+I+(J-1)*N ) + 420 CONTINUE + 430 CONTINUE +C +C Compute eig( Binv*A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ11+1 ), N, SDIM, + $ ZWORK( IZ12+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + E = DREAL( ZWORK( IZ12+1 ) ) + IF( N.GT.1 ) THEN + DO 440 I = 2, N + IF( DREAL( ZWORK( IZ12+I ) ).GT.E ) + $ E = DREAL( ZWORK( IZ12+I ) ) + 440 CONTINUE + END IF +C +C Set tau. +C + IF( MR.GT.0 ) THEN + SNORM = ABS( X( M ) ) + IF( MR.GT.1 ) THEN + DO 450 I = M+1, MT + IF( ABS( X( I ) ).GT.SNORM ) SNORM = ABS( X( I ) ) + 450 CONTINUE + END IF + IF( SNORM.GT.FORTY ) THEN + TAU = C7 + ELSE IF( SNORM.GT.EIGHT ) THEN + TAU = FIFTY + ELSE IF( SNORM.GT.FOUR ) THEN + TAU = TEN + ELSE IF( SNORM.GT.ONE ) THEN + TAU = FIVE + ELSE + TAU = TWO + END IF + END IF + IF( ITER.EQ.0 ) THEN + DLAMBD = E + C1 + ELSE + DWORK( IW13+1 ) = E + CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) + DLAMBD = ( ONE - THETA )*DWORK( IW13+1 ) + + $ THETA*DWORK( IW14+1 ) + CALL DCOPY( MT, DWORK( IW13+2 ), 1, DWORK( IW18+1 ), 1 ) + CALL DCOPY( MT, DWORK( IW14+2 ), 1, DWORK( IW19+1 ), 1 ) + L = 0 + 460 DO 470 I = 1, MT + X( I ) = ( ONE - THETA / TWO**L )*DWORK( IW18+I ) + + $ ( THETA / TWO**L )*DWORK( IW19+I ) + 470 CONTINUE +C +C Compute At(:) = A0 + AA*x. +C + DO 480 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 480 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ9+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ9+1 ), 1 ) +C +C Compute diag(Bt). +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW21+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, + $ DWORK( IW21+1 ), 1 ) +C +C Compute W. +C + DO 500 J = 1, N + DO 490 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ13+I+(I-1)*N ) = DCMPLX( THETA*BETA* + $ ( DWORK( IW14+1 ) - DWORK( IW13+1 ) ) /TWO - + $ DLAMBD*DWORK( IW21+I ) ) + + $ ZWORK( IZ9+I+(I-1)*N ) + ELSE + ZWORK( IZ13+I+(J-1)*N ) = ZWORK( IZ9+I+(J-1)*N ) + END IF + 490 CONTINUE + 500 CONTINUE +C +C Compute eig( W ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ13+1 ), N, SDIM, + $ ZWORK( IZ14+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMAX = DREAL( ZWORK( IZ14+1 ) ) + IF( N.GT.1 ) THEN + DO 510 I = 2, N + IF( DREAL( ZWORK( IZ14+I ) ).GT.EMAX ) + $ EMAX = DREAL( ZWORK( IZ14+I ) ) + 510 CONTINUE + END IF + IF( EMAX.LE.ZERO ) THEN + GO TO 515 + ELSE + L = L + 1 + GO TO 460 + END IF + END IF +C +C Set y. +C + 515 DWORK( IW13+1 ) = DLAMBD + CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) +C + IF( ( SVLAM - DLAMBD ).LT.TOL ) THEN + BOUND = SQRT( MAX( E, ZERO ) )*ZNORM + DO 520 I = 1, M - 1 + X( I ) = X( I )*DWORK( IW2+I+1 )**2 + 520 CONTINUE +C +C Compute sqrt( x ). +C + DO 530 I = 1, M-1 + DWORK( IW20+I ) = SQRT( X( I ) ) + 530 CONTINUE +C +C Compute diag( D ). +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, D, 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW20+1 ), 1, ONE, D, 1 ) +C +C Compute diag( G ). +C + J = 0 + L = 0 + DO 540 K = 1, M + J = J + NBLOCK( K ) + IF( ITYPE( K ).EQ.1 ) THEN + L = L + 1 + X( M-1+L ) = X( M-1+L )*DWORK( IW2+K )**2 + G( J ) = X( M-1+L ) + END IF + 540 CONTINUE + CALL DSCAL( N, ZNORM, G, 1 ) + DWORK( 1 ) = DFLOAT( MINWRK - 5*N + LWAMAX ) + ZWORK( 1 ) = DCMPLX( MINZRK - 3*N + LZAMAX ) + RETURN + END IF + SVLAM = DLAMBD + DO 800 K = 1, M +C +C Store xD. +C + CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*x. +C + DO 550 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 550 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute B = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute F. +C + DO 556 J = 1, N + DO 555 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 555 CONTINUE + 556 CONTINUE + CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, + $ ZWORK( IZ17+1 ), N ) +C +C Compute det( F ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + DETF = CONE + DO 560 I = 1, N + DETF = DETF*ZWORK( IZ16+I ) + 560 CONTINUE +C +C Compute Finv. +C + CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) +C +C Compute phi. +C + DO 570 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 570 CONTINUE + IF( MR.GT.0 ) THEN + DO 580 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 580 CONTINUE + END IF + PROD = ONE + DO 590 I = 1, 2*MT + PROD = PROD*DWORK( IW25+I ) + 590 CONTINUE + TEMP = DREAL( DETF ) + IF( TEMP.LT.EPS ) TEMP = EPS + PHI = -LOG( TEMP ) - LOG( PROD ) +C +C Compute g. +C + DO 610 J = 1, MT + DO 600 I = 1, N*N + ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* + $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) + 600 CONTINUE + 610 CONTINUE + CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, + $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) + DO 620 I = 1, M-1 + DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - + $ ONE / ( ALPHA - DWORK( IW22+I ) ) + 620 CONTINUE + IF( MR.GT.0 ) THEN + DO 630 I = 1, MR + DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) + $ -ONE / ( TAU - DWORK( IW23+I ) ) + 630 CONTINUE + END IF + DO 640 I = 1, MT + DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - + $ DWORK( IW26+I ) + 640 CONTINUE +C +C Compute h. +C + CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, + $ DWORK( IW31+1 ), MT ) + CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IW27+1 ), MT, DWORK( IWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) + STSIZE = ONE +C +C Store hD. +C + CALL DCOPY( M-1, DWORK( IW27+1 ), 1, DWORK( IW28+1 ), 1 ) +C +C Determine stepsize. +C + L = 0 + DO 650 I = 1, M-1 + IF( DWORK( IW28+I ).GT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( DWORK( IW22+I ) - BETA ) / DWORK( IW28+I ) + ELSE + TEMP = MIN( TEMP, ( DWORK( IW22+I ) - BETA ) / + $ DWORK( IW28+I ) ) + END IF + END IF + 650 CONTINUE + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + L = 0 + DO 660 I = 1, M-1 + IF( DWORK( IW28+I ).LT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( ALPHA - DWORK( IW22+I ) ) / + $ ( -DWORK( IW28+I ) ) + ELSE + TEMP = MIN( TEMP, ( ALPHA - DWORK( IW22+I ) ) / + $ ( -DWORK( IW28+I ) ) ) + END IF + END IF + 660 CONTINUE + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + IF( MR.GT.0 ) THEN +C +C Store hG. +C + CALL DCOPY( MR, DWORK( IW27+M ), 1, DWORK( IW29+1 ), 1 ) +C +C Determine stepsize. +C + L = 0 + DO 670 I = 1, MR + IF( DWORK( IW29+I ).GT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( DWORK( IW23+I ) + TAU ) / + $ DWORK( IW29+I ) + ELSE + TEMP = MIN( TEMP, ( DWORK( IW23+I ) + TAU ) / + $ DWORK( IW29+I ) ) + END IF + END IF + 670 CONTINUE + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + L = 0 + DO 680 I = 1, MR + IF( DWORK( IW29+I ).LT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( TAU - DWORK( IW23+I ) ) / + $ ( -DWORK( IW29+I ) ) + ELSE + TEMP = MIN( TEMP, ( TAU - DWORK( IW23+I ) ) / + $ ( -DWORK( IW29+I ) ) ) + END IF + END IF + 680 CONTINUE + END IF + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + STSIZE = C4*STSIZE + IF( STSIZE.GE.TOL4 ) THEN +C +C Compute x_new. +C + DO 700 I = 1, MT + DWORK( IW20+I ) = X( I ) - STSIZE*DWORK( IW27+I ) + 700 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), + $ 1 ) + END IF +C +C Compute A(:) = A0 + AA*x_new. +C + DO 710 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) + 710 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute B = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute lambda*diag(B) - A. +C + DO 730 J = 1, N + DO 720 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = + $ -ZWORK( IZ7+I+(J-1)*N ) + END IF + 720 CONTINUE + 730 CONTINUE +C +C Compute eig( lambda*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, + $ SDIM, ZWORK( IZ16+1 ), ZWORK, N, + $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, + $ DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 740 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 740 CONTINUE + END IF + DO 750 I = 1, N + DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) + 750 CONTINUE + DO 760 I = 1, M-1 + DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA + DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) + 760 CONTINUE + IF( MR.GT.0 ) THEN + DO 770 I = 1, MR + DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - + $ DWORK( IW23+I ) + 770 CONTINUE + END IF + PROD = ONE + DO 780 I = 1, N+2*MT + PROD = PROD*DWORK( IW30+I ) + 780 CONTINUE + IF( EMIN.LE.ZERO .OR. ( -LOG( PROD ) ).GE.PHI ) THEN + STSIZE = STSIZE / TEN + ELSE + CALL DCOPY( MT, DWORK( IW20+1 ), 1, X, 1 ) + END IF + END IF + IF( STSIZE.LT.TOL4 ) GO TO 810 + 800 CONTINUE +C + 810 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*x. +C + DO 820 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 820 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute F. +C + DO 840 J = 1, N + DO 830 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 830 CONTINUE + 840 CONTINUE + CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, + $ ZWORK( IZ17+1 ), N ) +C +C Compute det( F ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + DETF = CONE + DO 850 I = 1, N + DETF = DETF*ZWORK( IZ16+I ) + 850 CONTINUE +C +C Compute Finv. +C + CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) +C +C Compute the barrier function. +C + DO 860 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 860 CONTINUE + IF( MR.GT.0 ) THEN + DO 870 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 870 CONTINUE + END IF + PROD = ONE + DO 880 I = 1, 2*MT + PROD = PROD*DWORK( IW25+I ) + 880 CONTINUE + TEMP = DREAL( DETF ) + IF( TEMP.LT.EPS ) TEMP = EPS + PHI = -LOG( TEMP ) - LOG( PROD ) +C +C Compute the gradient of the barrier function. +C + DO 900 J = 1, MT + DO 890 I = 1, N*N + ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* + $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) + 890 CONTINUE + 900 CONTINUE + CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, + $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) + DO 910 I = 1, M-1 + DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - + $ ONE / ( ALPHA - DWORK( IW22+I ) ) + 910 CONTINUE + IF( MR.GT.0 ) THEN + DO 920 I = 1, MR + DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) + $ -ONE / ( TAU - DWORK( IW23+I ) ) + 920 CONTINUE + END IF + DO 925 I = 1, MT + DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - + $ DWORK( IW26+I ) + 925 CONTINUE +C +C Compute the Hessian of the barrier function. +C + CALL ZGEMM( 'N', 'N', N, N*MT, N, CONE, ZWORK( IZ17+1 ), N, + $ ZWORK( IZ18+1 ), N, CZERO, ZWORK( IZ20+1 ), N ) + + CALL DLASET( 'Full', MT, MT, ZERO, ZERO, DWORK( IW11+1 ), + $ MT ) + DO 960 K = 1, MT + CALL ZCOPY( N*N, ZWORK( IZ20+1+(K-1)*N*N ), 1, + $ ZWORK( IZ22+1 ), 1 ) + DO 940 J = 1, N + DO 930 I = 1, N + ZWORK( IZ23+I+(J-1)*N ) = + $ DCONJG( ZWORK( IZ22+J+(I-1)*N ) ) + 930 CONTINUE + 940 CONTINUE + CALL ZGEMV( 'C', N*N, K, CONE, ZWORK( IZ20+1 ), N*N, + $ ZWORK( IZ23+1 ), 1, CZERO, ZWORK( IZ24+1 ), + $ 1 ) + DO 950 J = 1, K + DWORK( IW11+K+(J-1)*MT ) = + $ DREAL( DCONJG( ZWORK( IZ24+J ) ) ) + 950 CONTINUE + 960 CONTINUE + DO 970 I = 1, M-1 + DWORK( IW10+I ) = ONE / ( DWORK( IW22+I ) - BETA )**2 + + $ ONE / ( ALPHA - DWORK( IW22+I ) )**2 + 970 CONTINUE + IF( MR.GT.0 ) THEN + DO 980 I = 1, MR + DWORK( IW10+M-1+I ) = + $ ONE / ( DWORK( IW23+I ) + TAU )**2 + + $ ONE / ( TAU - DWORK( IW23+I ) )**2 + 980 CONTINUE + END IF + DO 990 I = 1, MT + DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + + $ DWORK( IW10+I ) + 990 CONTINUE + DO 1100 J = 1, MT + DO 1000 I = 1, J + IF( I.NE.J ) THEN + T1 = DWORK( IW11+I+(J-1)*MT ) + T2 = DWORK( IW11+J+(I-1)*MT ) + DWORK( IW11+I+(J-1)*MT ) = T1 + T2 + DWORK( IW11+J+(I-1)*MT ) = T1 + T2 + END IF + 1000 CONTINUE + 1100 CONTINUE +C +C Compute norm( H ). +C + 1110 HNORM = DLANGE( 'F', MT, MT, DWORK( IW11+1 ), MT, DWORK ) +C +C Compute rcond( H ). +C + CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, + $ DWORK( IW31+1 ), MT ) + HNORM1 = DLANGE( '1', MT, MT, DWORK( IW31+1 ), MT, DWORK ) + CALL DSYTRF( 'U', MT, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) + CALL DSYCON( 'U', MT, DWORK( IW31+1 ), MT, IWORK, HNORM1, + $ RCOND, DWORK( IWRK+1 ), IWORK( MT+1 ), INFO2 ) + IF( RCOND.LT.TOL3 ) THEN + DO 1120 I = 1, MT + DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + + $ HNORM*REGPAR + 1120 CONTINUE + GO TO 1110 + END IF +C +C Compute the tangent line to path of center. +C + CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + CALL DSYTRS( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IW27+1 ), MT, INFO2 ) +C +C Check if x-h satisfies the Goldstein test. +C + GTEST = .FALSE. + DO 1130 I = 1, MT + DWORK( IW20+I ) = X( I ) - DWORK( IW27+I ) + 1130 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*x_new. +C + DO 1140 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) + 1140 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute lambda*diag(B) - A. +C + DO 1160 J = 1, N + DO 1150 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1150 CONTINUE + 1160 CONTINUE +C +C Compute eig( lambda*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + DO 1190 I = 1, N + DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) + 1190 CONTINUE + DO 1200 I = 1, M-1 + DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA + DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1200 CONTINUE + IF( MR.GT.0 ) THEN + DO 1210 I = 1, MR + DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1210 CONTINUE + END IF + EMIN = DWORK( IW30+1 ) + DO 1220 I = 1, N+2*MT + IF( DWORK( IW30+I ).LT.EMIN ) EMIN = DWORK( IW30+I ) + 1220 CONTINUE + IF( EMIN.LE.ZERO ) THEN + GTEST = .FALSE. + ELSE + PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + PROD = ONE + DO 1230 I = 1, N+2*MT + PROD = PROD*DWORK( IW30+I ) + 1230 CONTINUE + T1 = -LOG( PROD ) + T2 = PHI - C2*PP + T3 = PHI - C4*PP + IF( T1.GE.T3 .AND. T1.LT.T2 ) GTEST = .TRUE. + END IF +C +C Use x-h if Goldstein test is satisfied. Otherwise use +C Nesterov-Nemirovsky's stepsize length. +C + PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + DELTA = SQRT( PP ) + IF( GTEST .OR. DELTA.LE.C3 ) THEN + DO 1240 I = 1, MT + X( I ) = X( I ) - DWORK( IW27+I ) + 1240 CONTINUE + ELSE + DO 1250 I = 1, MT + X( I ) = X( I ) - DWORK( IW27+I ) / ( ONE + DELTA ) + 1250 CONTINUE + END IF +C +C Analytic center is found if delta is sufficiently small. +C + IF( DELTA.LT.TOL5 ) GO TO 1260 + GO TO 810 +C +C Set yf. +C + 1260 DWORK( IW14+1 ) = DLAMBD + CALL DCOPY( MT, X, 1, DWORK( IW14+2 ), 1 ) +C +C Set yw. +C + CALL DCOPY( MT+1, DWORK( IW14+1 ), 1, DWORK( IW15+1 ), 1 ) +C +C Compute Fb. +C + DO 1280 J = 1, N + DO 1270 I = 1, N + ZWORK( IZ21+I+(J-1)*N ) = DCMPLX( DWORK( IW24+I ) )* + $ DCONJG( ZWORK( IZ17+J+(I-1)*N ) ) + 1270 CONTINUE + 1280 CONTINUE + CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ20+1 ), N*N, + $ ZWORK( IZ21+1 ), 1, CZERO, ZWORK( IZ24+1 ), 1 ) + DO 1300 I = 1, MT + DWORK( IW32+I ) = DREAL( ZWORK( IZ24+I ) ) + 1300 CONTINUE +C +C Compute h1. +C + CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, + $ DWORK( IW31+1 ), MT ) + CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IW32+1 ), MT, DWORK( IWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +C +C Compute hn. +C + HN = DLANGE( 'F', MT, 1, DWORK( IW32+1 ), MT, DWORK ) +C +C Compute y. +C + DWORK( IW13+1 ) = DLAMBD - C / HN + DO 1310 I = 1, MT + DWORK( IW13+1+I ) = X( I ) + C*DWORK( IW32+I ) / HN + 1310 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*y(2:mt+1). +C + DO 1320 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) + 1320 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute B = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute y(1)*diag(B) - A. +C + DO 1340 J = 1, N + DO 1330 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1330 CONTINUE + 1340 CONTINUE +C +C Compute eig( y(1)*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 1350 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 1350 CONTINUE + END IF + POS = .TRUE. + DO 1360 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1360 CONTINUE + IF( MR.GT.0 ) THEN + DO 1370 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1370 CONTINUE + END IF + TEMP = DWORK( IW25+1 ) + DO 1380 I = 2, 2*MT + IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) + 1380 CONTINUE + IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. + 1390 IF( POS ) THEN +C +C Set y2 = y. +C + CALL DCOPY( MT+1, DWORK( IW13+1 ), 1, DWORK( IW17+1 ), 1 ) +C +C Compute y = y + 1.5*( y - yw ). +C + DO 1400 I = 1, MT+1 + DWORK( IW13+I ) = DWORK( IW13+I ) + + $ C5*( DWORK( IW13+I ) - DWORK( IW15+I ) ) + 1400 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, + $ DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*y(2:mt+1). +C + DO 1420 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) + 1420 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Set yw = y2. +C + CALL DCOPY( MT+1, DWORK( IW17+1 ), 1, DWORK( IW15+1 ), 1 ) +C +C Compute y(1)*diag(B) - A. +C + DO 1440 J = 1, N + DO 1430 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1430 CONTINUE + 1440 CONTINUE +C +C Compute eig( y(1)*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 1450 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 1450 CONTINUE + END IF + POS = .TRUE. + DO 1460 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1460 CONTINUE + IF( MR.GT.0 ) THEN + DO 1470 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1470 CONTINUE + END IF + TEMP = DWORK( IW25+1 ) + DO 1480 I = 2, 2*MT + IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) + 1480 CONTINUE + IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. + GO TO 1390 + END IF + 1490 CONTINUE +C +C Set y1 = ( y + yw ) / 2. +C + DO 1500 I = 1, MT+1 + DWORK( IW16+I ) = ( DWORK( IW13+I ) + DWORK( IW15+I ) ) + $ / TWO + 1500 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW16+2 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW16+M+1 ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*y1(2:mt+1). +C + DO 1510 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW16+1+I ) ) + 1510 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute y1(1)*diag(B) - A. +C + DO 1530 J = 1, N + DO 1520 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW16+1 )* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1520 CONTINUE + 1530 CONTINUE +C +C Compute eig( y1(1)*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 1540 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 1540 CONTINUE + END IF + POS = .TRUE. + DO 1550 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1550 CONTINUE + IF( MR.GT.0 ) THEN + DO 1560 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1560 CONTINUE + END IF + TEMP = DWORK( IW25+1 ) + DO 1570 I = 2, 2*MT + IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) + 1570 CONTINUE + IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. + IF( POS ) THEN +C +C Set yw = y1. +C + CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW15+1 ), 1 ) + ELSE +C +C Set y = y1. +C + CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW13+1 ), 1 ) + END IF + DO 1580 I = 1, MT+1 + DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW15+I ) + 1580 CONTINUE + YNORM1 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) + DO 1590 I = 1, MT+1 + DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW14+I ) + 1590 CONTINUE + YNORM2 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) + IF( YNORM1.LT.YNORM2*THETA ) GO TO 1600 + GO TO 1490 +C +C Compute c. +C + 1600 DO 1610 I = 1, MT+1 + DWORK( IW33+I ) = DWORK( IW15+I ) - DWORK( IW14+I ) + 1610 CONTINUE + C = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) +C +C Set x = yw(2:mt+1). +C + CALL DCOPY( MT, DWORK( IW15+2 ), 1, X, 1 ) + GO TO 390 +C +C *** Last line of AB13MD *** + END diff --git a/modules/cacsd/src/slicot/ab13md.lo b/modules/cacsd/src/slicot/ab13md.lo new file mode 100755 index 000000000..fd7731b27 --- /dev/null +++ b/modules/cacsd/src/slicot/ab13md.lo @@ -0,0 +1,12 @@ +# src/slicot/ab13md.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ab13md.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ereduc.f b/modules/cacsd/src/slicot/ereduc.f new file mode 100755 index 000000000..6e9eb2b81 --- /dev/null +++ b/modules/cacsd/src/slicot/ereduc.f @@ -0,0 +1,137 @@ + SUBROUTINE EREDUC(E, M, N, Q, Z, ISTAIR, RANKE, TOL) +C PURPOSE: +C +C Given an M x N matrix E (not necessarily regular) the subroutine +C EREDUC computes a unitary transformed matrix Q*E*Z which is in +C column echelon form (trapezoidal form). Furthermore the rank of +C matrix E is determined. +C +C CONTRIBUTOR: Th.G.J. Beelen (Philips Glass Eindhoven). +C Copyright SLICOT +C +C REVISIONS: 1988, January 29. +C +C Specification of the parameters. +C +C .. Scalar arguments .. +C + INTEGER LDE, LDQ, LDZ, M, N, RANKE + DOUBLE PRECISION TOL +C +C .. Array arguments .. +C + INTEGER ISTAIR(M) +C DOUBLE PRECISION E(LDE,N), Q(LDQ,M), Z(LDZ,N) +C SET E(M,N) Q(M,M) Z(N,N) + DOUBLE PRECISION E(M,N), Q(M,M), Z(N,N) +C Local variables. +C + INTEGER I, J, JMX, K, KM1, L, LK, MNK, NR1 + DOUBLE PRECISION EMXNRM, EMX, SC, SS + LOGICAL LZERO +C + LDE=M + LDQ=M + LDZ=N + do 991 i=1,m + do 991 j=1,m + q(i,j)=0.d0 + 991 continue + do 992 i=1,m + q(i,i)=1.0d0 + 992 continue + do 993 i=1,n + do 993 j=1,n + z(i,j)=0.d0 + 993 continue + do 994 i=1,n + z(i,i)=1.0d0 + 994 continue + RANKE = MIN0(M,N) +C + K = N + LZERO = .FALSE. +C +C WHILE ((K > 0) AND (NOT a zero submatrix encountered) DO + 10 IF ((K .GT. 0) .AND. (.NOT.LZERO)) THEN +C +C + MNK = M - N + K + EMXNRM = 0.0D0 + LK = MNK + DO 20 L = MNK, 1, -1 + JMX = IDAMAX(K, E(L,1), LDE) + EMX = DABS(E(L,JMX)) + IF (EMX .GT. EMXNRM) THEN + EMXNRM = EMX + LK = L + END IF + 20 CONTINUE +C + IF (EMXNRM .LT. TOL) THEN +C +C Set submatrix Ek to zero. +C + DO 40 J = 1, K + DO 30 L = 1, MNK + E(L,J) = 0.0D0 + 30 CONTINUE + 40 CONTINUE + 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 E-matrix and +C update the row transformation matrix Q. +C (# elements involved = m) +C + CALL DSWAP(N, E(LK,1), LDE, E(MNK,1), LDE) + CALL DSWAP(M, Q(LK,1), LDQ, Q(MNK,1), LDQ) + END IF +C + KM1 = K - 1 + DO 50 J = 1, KM1 +C +C Determine the column Givens transformation to annihilate +C E(m-n+k,j) using E(m-n+k,k) as pivot. +C Apply the transformation to the columns of Ek. +C (# elements involved = m-n+k) +C Update the column transformation matrix Z. +C (# elements involved = n) +C + CALL DGIV(E(MNK,K), E(MNK,J), SC, SS) + CALL DROT(MNK, E(1,K), 1, E(1,J), 1, SC, SS) + E(MNK, J) = 0.0D0 + CALL DROT(N, Z(1,K), 1, Z(1,J), 1, SC, SS) + 50 CONTINUE +C + K = K - 1 + END IF + GOTO 10 + END IF +C END WHILE 10 +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 pt. +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 = 1, RANKE + ISTAIR(M - I + 1) = N - I + 1 + 60 CONTINUE +C + NR1 = N - RANKE + 1 + DO 70 I = RANKE, M - 1 + ISTAIR(M-I) = -NR1 + 70 CONTINUE +C + RETURN +C *** Last line of EREDUC ********************************************* + END diff --git a/modules/cacsd/src/slicot/ereduc.lo b/modules/cacsd/src/slicot/ereduc.lo new file mode 100755 index 000000000..f4fcaadf8 --- /dev/null +++ b/modules/cacsd/src/slicot/ereduc.lo @@ -0,0 +1,12 @@ +# src/slicot/ereduc.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ereduc.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/fstair.f b/modules/cacsd/src/slicot/fstair.f new file mode 100755 index 000000000..9a010004e --- /dev/null +++ b/modules/cacsd/src/slicot/fstair.f @@ -0,0 +1,1573 @@ + SUBROUTINE FSTAIR (A, E, Q, Z, M, N, ISTAIR, RANKE, TOL, + * NBLCKS, IMUK, INUK, IMUK0, INUK0, + * MNEI, WRK, IWRK,IERR) +C PURPOSE: +C +C Given a pencil sE-A where matrix E is in column echelon form the +C subroutine FSTAIR computes according to the wishes of the user a +C unitary transformed pencil Q(sE-A)Z which is more or less similar +C to the generalized Schur form of the pencil sE-A. +C The subroutine yields also part of the Kronecker structure of +C the given pencil. +C +C CONTRIBUTOR: Th.G.J. Beelen (Philips Glass Eindhoven). +C Copyright SLICOT +C +C REVISIONS: 1988, February 02. +C +C*********************************************************************** +C +C Philips Glass Eindhoven +C 5600 MD Eindhoven, Netherlands +C +C*********************************************************************** +C FSTAIR - SLICOT Library Routine Document +C +C 1 PURPOSE: +C +C Given a pencil sE-A where matrix E is in column echelon form the +C subroutine FSTAIR computes according to the wishes of the user a +C unitary transformed pencil Q(sE-A)Z which is more or less similar +C to the generalized Schur form of the pencil sE-A. The computed form +C yields part of the Kronecker structure of the given pencil. +C +C 2 SPECIFICATION: +C +C SUBROUTINE FSTAIR(A, LDA, E, Q, LDQ, Z, LDZ, M, N, ISTAIR, RANKE, +C NBLCKS, IMUK, INUK, IMUK0, INUK0, MNEI, +C WRK, IWRK, TOL, MODE, IERR) +C INTEGER LDA, LDQ, LDZ, M, N, RANKE, NBLCKS, MODE, IERR +C INTEGER ISTAIR(M), IMUK(N), INUK(M+1), IMUK0(N), INUK0(M+1), +C INTEGER MNEI(4), IWRK(N) +C DOUBLE PRECISION TOL +C DOUBLE PRECISION WRK(N) +C DOUBLE PRECISION A(LDA,N), E(LDA,N), Q(LDQ,M), Z(LDZ,N) +C +C 3 ARGUMENT LIST: +C +C 3.1 ARGUMENTS IN +C +C A - DOUBLE PRECISION array of DIMENSION (LDA,N). +C The leading M x N part of this array contains the M x N +C matrix A that has to be row compressed. +C NOTE: this array is overwritten. +C +C LDA - INTEGER +C LDA is the leading dimension of the arrays A and E. +C (LDA >= M) +C +C E - DOUBLE PRECISION array of DIMENSION (LDA,N). +C The leading M x N part of this array contains the M x N +C matrix E which will be transformed equivalent to matrix +C A. +C On entry, matrix E has to be in column echelon form. +C This may be accomplished by subroutine EREDUC. +C NOTE: this array is overwritten. +C +C Q - DOUBLE PRECISION array of DIMENSION (LDQ,M). +C The leading M x M part of this array contains an M x M +C unitary row transformation matrix corresponding to the +C row transformations of the matrices A and E which are +C needed to transform an arbitrary pencil to a pencil +C where E is in column echelon form. +C NOTE: this array is overwritten. +C +C LDQ - INTEGER +C LDQ is the leading dimension of the array Q. +C (LDQ >= M) +C +C Z - DOUBLE PRECISION array of DIMENSION (LDZ,N). +C The leading N x N part of this array contains an N x N +C unitary column transformation matrix corresponding to +C the column transformations of the matrices A and E +C which are needed to transform an arbitrary pencil to +C a pencil where E is in column echelon form. +C NOTE: this array is overwritten. +C +C LDZ - INTEGER +C LDZ is the leading dimension of the array Z. +C (LDZ >= N) +C +C M - INTEGER +C M is the number of rows of the matrices A, E and Q. +C +C N - INTEGER +C N is the number of columns of the matrices A, E and Z. +C +C ISTAIR - INTEGER array of DIMENSION (M). +C ISTAIR contains the information on the column echelon +C form of the input matrix E. This may be accomplished +C by subroutine EREDUC. +C ISTAIR(i) = + j if the boundary element E(i,j) is a +C corner point. +C - j if the boundary element E(i,j) is not +C a corner point. +C (i=1,...,M) +C NOTE: this array is destroyed. +C +C RANKE - INTEGER +C RANKE is the rank of the input matrix E being in column +C echelon form. +C +C 3.2 ARGUMENTS OUT +C +C A - DOUBLE PRECISION array of DIMENSION (LDA,N). +C The leading M x N part of this array contains the M x N +C matrix A that has been row compressed while keeping E +C in column echelon form. +C +C E - DOUBLE PRECISION array of DIMENSION (LDA,N). +C The leading M x N part of this array contains the M x N +C matrix E that has been transformed equivalent to matrix +C A. +C +C Q - DOUBLE PRECISION array of DIMENSION (LDQ,M). +C The leading M x M part of this array contains the M x M +C unitary matrix Q which is the product of the input +C matrix Q and the row transformation matrix which has +C transformed the rows of the matrices A and E. +C +C Z - DOUBLE PRECISION array of DIMENSION (LDZ,N). +C The leading N x N part of this array contains the N x N +C unitary matrix Z which is the product of the input +C matrix Z and the column transformation matrix which has +C transformed the columns of the matrices A and E. +C +C NBLCKS - INTEGER +C NBLCKS is the number of submatrices having +C full row rank >= 0 detected in matrix A. +C +C IMUK - INTEGER array of DIMENSION (N). +C Array IMUK contains the column dimensions mu(k) +C (k=1,...,NBLCKS) of the submatrices having full column +C rank in the pencil sE(x)-A(x) +C where x = eps,inf if MODE = 1 or 2 +C eps MODE = 3 . +C +C INUK - INTEGER array of DIMENSION (M+1). +C Array INUK contains the row dimensions nu(k) +C (k=1,...,NBLCKS) of the submatrices having full row +C rank in the pencil sE(x)-A(x) +C where x = eps,inf if MODE = 1 or 2 +C eps MODE = 3 . +C +C IMUK0 - INTEGER array of DIMENSION (N). +C Array IMUK0 contains the column dimensions mu(k) +C (k=1,...,NBLCKS) of the submatrices having full column +C rank in the pencil sE(eps,inf)-A(eps,inf). +C +C INUK0 - INTEGER array of DIMENSION (M+1). +C Array INUK0 contains the row dimensions nu(k) +C (k=1,...,NBLCKS) of the submatrices having full row +C rank in the pencil sE(eps,inf)-A(eps,inf). +C +C MNEI - INTEGER array of DIMENSION (4). +C If MODE = 3 then +C MNEI(1) = row dimension of sE(eps)-A(eps) +C 2 = column dimension of sE(eps)-A(eps) +C 3 = row dimension of sE(inf)-A(inf) +C 4 = column dimension of sE(inf)-A(inf) +C If MODE = 1 or 2 then the array MNEI is empty. +C +C 3.3 WORK SPACE +C +C WRK - DOUBLE PRECISION array of DIMENSION (N). +C +C IWRK - INTEGER array of DIMENSION (N). +C +C 3.4 TOLERANCES +C +C TOL - DOUBLE PRECISION +C TOL is the tolerance used when considering matrix +C elements to be zero. TOL should be set to +C TOL = RE * max( ||A|| , ||E|| ) + AE , where +C ||.|| is the Frobenius norm. AE and RE are the absolute +C and relative accuracy. +C A recommanded choice is AE = EPS and RE = 100*EPS, +C where EPS is the machine precision. +C +C 3.5 MODE PARAMETERS +C +C MODE - INTEGER +C According to the value of MODE the subroutine FSTAIR +C computes a generalized Schur form of the pencil sE-A, +C where the structure of the generalized Schur form is +C specified more the higher the value of MODE is. +C (See also 6 DESCRIPTION). +C +C 3.6 ERROR INDICATORS +C +C IERR - INTEGER +C On return, IERR contains 0 unless the subroutine +C has failed. +C +C 4 ERROR INDICATORS and WARNINGS: +C +C IERR = -1: the value of MODE is not 1, 2 or 3. +C IERR = 0: succesfull completion. +C IERR = 1: the algorithm has failed. +C +C 5 AUXILARY ROUTINES and COMMON BLOCKS: +C +C BAE, SQUAEK, TRIRED from SLICOT. +C +C 6 DESCRIPTION: +C +C On entry, matrix E is assumed to be in column echelon form. +C Depending on the value of the parameter MODE, submatrices of A +C and E will be reduced to a specific form. The higher the value of +C MODE, the more the submatrices are transformed. +C +C Step 1 of the algorithm. +C If MODE = 1 then subroutine FSTAIR transforms the matrices A and +C E to the following generalized Schur form by unitary transformations +C Q1 and Z1, using subroutine BAE. (See also Algorithm 3.2.1 in [1]). +C +C | sE(eps,inf)-A(eps,inf) | X | +C Q1(sE-A)Z1 = |------------------------|------------| +C | O | sE(r)-A(r) | +C +C Here the pencil sE(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 sE-A. +C The pencil sE(r)-A(r) contains all Kronecker row indices and +C elementary divisors of sE-A. +C NOTE: X is a pencil. +C +C Step 2 of the algorithm. +C If MODE = 2 then furthermore the submatrices having full row and +C column rank in the pencil sE(eps,inf)-A(eps,inf) are triangularized +C by applying unitary transformations Q2 and Z2 to Q1*(sE-A)*Z1. This +C is done by subroutine TRIRED. (see also Algorithm 3.3.1 [1]). +C +C Step 3 of the algorithm. +C If MODE = 3 then moreover the pencils sE(eps)-A(eps) and +C sE(inf)-A(inf) are separated in sE(eps,inf)-A(eps,inf) by applying +C unitary transformations Q3 and Z3 to Q2*Q1*(sE-A)*Z1*Z2. This is +C done by subroutine SQUAEK. (See also Algorithm 3.3.3 in [1]). +C We then obtain +C +C | sE(eps)-A(eps) | X | X | +C |----------------|----------------|------------| +C | O | sE(inf)-A(inf) | X | +C Q(sE-A)Z = |=================================|============| (1) +C | | | +C | O | sE(r)-A(r) | +C +C where Q = Q3*Q2*Q1 and Z = Z1*Z2*Z3. +C The accumulated row and column transformations are multiplied on +C the left and right respectively with the contents of the arrays Q +C and Z on entry and the results are stored in Q and Z, respectively. +C NOTE: the pencil sE(r)-A(r) is not reduced furthermore. +C +C Now let sE-A be an arbitrary pencil. This pencil has to be +C transformed into a pencil with E in column echelon form before +C calling FSTAIR. This may be accomplished by the subroutine EREDUC. +C Let the therefore needed unitary row and column transformations be +C Q0 and Z0, respectively. +C Let, on entry, the arrays Q and Z contain Q0 and Z0, and let ISTAIR +C contain the appropiate information. Then, on return with MODE = 3, +C the contents of the arrays Q and Z are Q3*Q2*Q1*Q0 and Z0*Z1*Z2*Z3 +C which are the transformation matrices that transform the arbitrary +C pencil sE-A into the form (1). +C +C 7 REFERENCES: +C +C [1] Th.G.J. Beelen, New Algorithms for Computing the Kronecker +C structure of a Pencil with Applications to Systems and Control +C Theory, Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C 8 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 9 FURTHER REMARKS: +C +C - The difference mu(k)-nu(k) = # Kronecker blocks of size kx(k+1). +C The number of these blocks is given by NBLCKS. +C - The difference nu(k)-mu(k+1) = # infinite elementary divisors of +C degree k (here mu(NBLCKS+1) := 0). +C - MNEI(3) = MNEI(4) since pencil sE(inf)-A(inf) is regular. +C - In the pencil sE(r)-A(r) the pencils sE(f)-A(f) and sE(eta)-A(eta) +C can be separated by pertransposing the pencil sE(r)-A(r) and +C using the last part of subroutine FSTAIR. The result has got to be +C pertransposed again. (For more details see section 3.3.1 in [1]). +C +C*********************************************************************** +C +C .. Scalar arguments .. +C + INTEGER LDA, LDQ, LDZ, M, N, RANKE, NBLCKS, MODE, IERR + DOUBLE PRECISION TOL +C +C .. Array arguments .. +C + INTEGER ISTAIR(M), IMUK(N), INUK(M+1), IMUK0(N), INUK0(M+1), + * MNEI(4), IWRK(N) + DOUBLE PRECISION A(M,N), E(M,N), Q(M,M), Z(N,N), + * WRK(N) +C +C EXTERNAL SUBROUTINES/FUNCTIONS: +C +C BAE, SQUAEK, TRIRED from SLICOT. +C +C Local variables. +C + INTEGER MEI, NEI, IFIRA, IFICA, NRA, NCA, JK, RANKA, + * ISMUK, ISNUK, I, K +C + LDA=M + LDE=M + LDQ=M + LDZ=N + MODE=3 + IERR = 0 +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 +C +C NBLCKS = # blocks detected in A with full row rank >= 0. +C + NBLCKS = 0 + K = 0 +C +C Initialization of the arrays INUK and IMUK. +C + DO 10 I = 1, M + 1 + INUK(I) = -1 + 10 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 20 I = 1, N + IMUK(I) = -1 + 20 CONTINUE +C +C Compress the rows of A while keeping E in column echelon form. +C +C REPEAT +C + 30 K = K + 1 + CALL BAE(A, LDA, E, Q, LDQ, Z, LDZ, M, N, ISTAIR, IFIRA, + * IFICA, NCA, RANKA, WRK, IWRK, TOL) + IMUK(K) = NCA + ISMUK = ISMUK + NCA + + INUK(K) = RANKA + ISNUK = ISNUK + RANKA + NBLCKS = NBLCKS + 1 +C +C If rank of A(k) = nrb then A has full row rank ; +C JK = first column index (in A) after right most column of +C matrix A(k+1). +C (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 = IABS(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) GOTO 30 +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). +C Ignoring these columns in E changes the ranks of the +C submatrices E(i), (i=1,...,k-1). +C +C MEI and NEI are the dimensions of the pencil +C sE(eps,inf)-A(eps,inf), i.e., the pencil that contains only +C Kronecker column indices and infinity elementary divisors. +C + MEI = ISNUK + NEI = ISMUK +C +C Save dimensions of the submatrices having full row or column rank +C in pencil sE(eps,inf)-A(eps,inf), i.e., copy the arrays +C IMUK and INUK to IMUK0 and INUK0, respectively. +C + DO 40 I = 1, M + 1 + INUK0(I) = INUK(I) + 40 CONTINUE +C + DO 50 I = 1, N + IMUK0(I) = IMUK(I) + 50 CONTINUE +C + IF (MODE .EQ. 1) RETURN +C +C Triangularization of the submatrices in A and E. +C + CALL TRIRED(A, LDA, E, Q, LDQ, Z, LDZ, M, N, NBLCKS, INUK, IMUK, + * IERR) +C + IF (IERR .NE. 0) then +c write(6,*) 'error: fstair failed!' + return + endif +C + IF (MODE .EQ. 2) RETURN +C +C Reduction to square submatrices E(k)'s in E. +C + CALL SQUAEK(A, LDA, E, Q, LDQ, Z, LDZ, M, N, NBLCKS, INUK, IMUK, + * MNEI) +C + RETURN +C *** Last line of FSTAIR ********************************************* + END + SUBROUTINE SQUAEK(A, LDA, E, Q, LDQ, Z, LDZ, M, N, NBLCKS, + * INUK, IMUK, MNEI) +C +C PURPOSE: +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 triangu- +C larized. +C Subroutine SQUAEK separates the pencils s*E(eps)-A(eps) and +C s*E(inf)-A(inf) in s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 +C in [1]. 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 furthermore. +C REMARK: This routine is intended to be called only from the +C SLICOT routine FSTAIR. +C +C PARAMETERS: +C +C A - DOUBLE PRECISION array of dimension (LDA,N). +C On entry, it contains the matrix AA to be reduced. +C On return, it contains the transformed matrix AA. +C E - DOUBLE PRECISION array of dimension (LDA,N). +C On entry, it contains the matrix EE to be reduced. +C On return, it contains the transformed matrix EE. +C Q - DOUBLE PRECISION array of dimension (LDQ,M). +C On entry, Q contains the row transformations corresponding to +C to the input matrices A and E. +C On return, it contains the product of the input matrix Q and +C the row transformation matrix that has transformed the rows +C of the matrices A and E. +C Z - DOUBLE PRECISION array of dimension (LDZ,N). +C On entry, Z contains the column transformations corresponding +C to the input matrices A and E. +C On return, it contains the product of the input matrix Z and +C the column transformation matrix that has transformed the +C columns of the matrices A and E. +C M - INTEGER. +C Number of rows of A and E. 1 <= M <= LDA. +C N - INTEGER. +C Number of columns of A and E. N >= 1. +C NBLCKS - INTEGER. +C Number of submatrices having full row rank >=0 in A(eps,inf). +C INUK - INTEGER array of dimension (NBLCKS). +C On entry, INUK contains the row dimensions nu(k), +C (k=1,..,NBLCKS) of the submatrices having full row rank in the +C pencil s*E(eps,inf)-A(eps,inf). +C On return, INUK contains the row dimensions nu(k), +C (k=1,..,NBLCKS) of the submatrices having full row rank in the +C pencil s*E(eps)-A(eps). +C IMUK - INTEGER array of dimension (NBLCKS). +C On entry, IMUK contains the column dimensions mu(k), +C (k=1,..,NBLCKS) of the submatrices having full column rank in +C the pencil s*E(eps,inf)-A(eps,inf). +C On return, IMUK contains the column dimensions mnu(k), +C (k=1,..,NBLCKS) of the submatrices having full column rank in +C the pencil s*E(eps)-A(eps). +C MNEI - INTEGER array of dimension (4). +C MNEI(1) = MEPS = row dimension of s*E(eps)-A(eps), +C 2 = NEPS = column dimension of s*E(eps)-A(eps), +C 3 = MINF = row dimension of s*E(inf)-A(inf), +C 4 = NINF = column dimension of s*E(inf)-A(inf). +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, Ph.D.Thesis, Eindhoven University of +C Technology, The Netherlands, 1987. +C +C CONTRIBUTOR: Th.G.J. Beelen (Philips Glas Eindhoven) +C +C REVISIONS: 1988, February 02. +C +C Specification of the parameters. +C +C .. Scalar arguments .. +C + INTEGER LDA, LDQ, LDZ, M, N, NBLCKS +C +C .. Array arguments .. +C + DOUBLE PRECISION A(LDA,N), E(LDA,N), Q(LDQ,M), Z(LDZ,N) + INTEGER INUK(NBLCKS), IMUK(NBLCKS), MNEI(4) +C +C EXTERNAL SUBROUTINES: +C +C DGIV, DROTI from SLICOT. +C +C Local variables. +C + DOUBLE PRECISION SC, SS + INTEGER SK1P1, TK1P1, TP1, TP + INTEGER ISMUK, ISNUK, MUKP1, MUK, NUK + INTEGER IP, J, K, MUP, MUP1, NUP, NELM + INTEGER MEPS, NEPS, MINF, NINF + INTEGER RA, CA, RE, CE, RJE, CJE, CJA +C +C Initialisation. +C + ISMUK = 0 + ISNUK = 0 + DO 10 K = 1, NBLCKS + ISMUK = ISMUK + IMUK(K) + ISNUK = ISNUK + INUK(K) + 10 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 60 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 + 20 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 + DO 50 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 pivot in A = (ra,ca). +C + TP1 = ISMUK + TK1P1 + RA = ISNUK + SK1P1 + CA = TP1 +C + MUP = IMUK(IP) + MUP1 = INUK(IP) + NUP = MUP1 +C + DO 30 J = 1, (MUP - NUP) +C +C CJA = current column index of pivot in A. +C + CJA = CA + J - 1 + CALL DGIV(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. +C + NELM = RA + CALL DROTI(NELM, A(1,CJA), 1, A(1,CJA+1), 1, SC, SS) + A(RA,CJA) = 0.0D0 + CALL DROTI(NELM, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS) + CALL DROTI(N, Z(1,CJA), 1, Z(1,CJA+1), 1, SC, SS) + 30 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 + RE = RA + 1 + TP = TP1 + MUP + CE = 1 + TP + CA = TP - MUP1 +C + DO 40 J = 1, MUP1 +C +C (RJE,CJE) = current position pivot in E. +C + RJE = RE + J - 1 + CJE = CE + J - 1 + CJA = CA + J - 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. +C + CALL DGIV(E(RJE,CJE), E(RJE-1,CJE), SC, SS) + NELM = N - CJE + 1 + CALL DROTI(NELM, E(RJE,CJE), LDA, E(RJE-1,CJE), LDA, + * SC, SS) + E(RJE,CJE) = 0.0D0 + NELM = N - CJA + 1 + CALL DROTI(NELM, A(RJE,CJA), LDA, A(RJE-1,CJA), LDA, + * SC, SS) + CALL DROTI(M, Q(RJE,1), LDQ, Q(RJE-1,1), LDQ, 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. +C + CALL DGIV(A(RJE,CJA), A(RJE,CJA+1), SC, SS) + NELM = RJE + CALL DROTI(NELM, A(1,CJA), 1, A(1,CJA+1), 1, SC, SS) + A(RJE,CJA) = 0.0D0 + CALL DROTI(NELM, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS) + CALL DROTI(N, Z(1,CJA), 1, Z(1,CJA+1), 1, SC, SS) + 40 CONTINUE +C + SK1P1 = SK1P1 + NUP + TK1P1 = TK1P1 + MUP +C + 50 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 + IMUK(K) = MUK + INUK(K) = NUK + ISMUK = ISMUK - 1 + ISNUK = ISNUK - 1 + MEPS = MEPS - 1 + NEPS = NEPS - 1 + MINF = MINF + 1 + NINF = NINF + 1 +C + GOTO 20 + END IF +C END WHILE 20 +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 + 60 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 SQUAEK ********************************************* + END +** END OF SQUAEKTEXT + SUBROUTINE TRIAAK(A, LDA, E, Z, LDZ, N, NRA, NCA, IFIRA, IFICA) +C +C PURPOSE: +C +C Subroutine TRIAAK reduces a submatrix A(k) of A to upper triangu- +C lar form by column 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 REMARK: This routine is intended to be called only from the +C SLICOT auxiliary routine TRIRED. +C +C PARAMETERS: +C +C A - DOUBLE PRECISION array of dimension (LDA,N). +C On entry, it contains the submatrix A(k) of full row rank +C to be reduced to upper triangular form. +C On return, it contains the transformed matrix A(k). +C E - DOUBLE PRECISION array of dimension (LDA,N). +C On entry, it contains the submatrix E(k). +C On return, it contains the transformed matrix E(k). +C Z - DOUBLE PRECISION array of dimension (LDZ,N). +C On entry, Z contains the column transformations corresponding +C to the input matrices A and E. +C On return, it contains the product of the input matrix Z and +C the column transformation matrix that has transformed the +C columns of the matrices A and E. +C N - INTEGER. +C Number of columns of A and E. (N >= 1). +C NRA - INTEGER. +C Number of rows in A(k) to be transformed (1 <= NRA <= LDA). +C NCA - INTEGER. +C Number of columns in A(k) to be transformed (1 <= NCA <= N). +C IFIRA - INTEGER. +C Number of first row in A(k) to be transformed. +C IFICA - INTEGER. +C Number of first column in A(k) to be transformed. +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, Ph.D.Thesis, Eindhoven University of +C Technology, The Netherlands, 1987. +C +C CONTRIBUTOR: Th.G.J. Beelen (Philips Glas Eindhoven) +C +C REVISIONS: 1988, January 29. +C +C Specification of the parameters. +C +C .. Scalar arguments .. +C + INTEGER LDA, LDZ, N, NRA, NCA, IFIRA, IFICA +C +C .. Array arguments .. +C + DOUBLE PRECISION A(LDA,N), E(LDA,N), Z(LDZ,N) +C +C EXTERNAL SUBROUTINES: +C +C DROT from BLAS +C DGIV from SLICOT. +C +C Local variables. +C + DOUBLE PRECISION SC, SS + INTEGER I, II, J, JJ, JJPVT, IFICA1, IFIRA1, MNI, NELM +C + IFIRA1 = IFIRA - 1 + IFICA1 = IFICA - 1 +C + DO 20 I = NRA, 1, -1 + II = IFIRA1 + I + MNI = NCA - NRA + I + JJPVT = IFICA1 + MNI + NELM = IFIRA1 + I + DO 10 J = MNI - 1, 1, -1 + JJ = IFICA1 + J +C +C Determine the Givens transformation on columns jj and jjpvt. +C Apply the transformation to these columns to annihilate +C A(ii,jj) (from rows 1 up to ifira1+i). +C Apply the transformation also to the E-matrix +C (from rows 1 up to ifira1). +C Update column transformation matrix Z. +C + CALL DGIV(A(II,JJPVT), A(II,JJ), SC, SS) + CALL DROT(NELM, A(1,JJPVT), 1, A(1,JJ), 1, SC, SS) + A(II,JJ) = 0.0D0 + CALL DROT(IFIRA1, E(1,JJPVT), 1, E(1,JJ), 1, SC, SS) + CALL DROT(N, Z(1,JJPVT), 1, Z(1,JJ), 1, SC, SS) + 10 CONTINUE + 20 CONTINUE +C + RETURN +C *** Last line of TRIAAK ********************************************* + END +** END OF TRIAAKTEXT +*UPTODATE TRIAEKTEXT + SUBROUTINE TRIAEK(A, LDA, E, Q, LDQ, M, N, NRE, NCE, IFIRE, + * IFICE, IFICA) +C +C PURPOSE: +C +C Subroutine TRIAEK reduces a submatrix E(k) of E to upper triangu- +C lar form by row 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 REMARK: This routine is intended to be called only from the +C SLICOT auxiliary routine TRIRED. +C +C PARAMETERS: +C +C A - DOUBLE PRECISION array of dimension (LDA,N). +C On entry, it contains the submatrix A(k). +C On return, it contains the transformed matrix A(k). +C E - DOUBLE PRECISION array of dimension (LDA,N). +C On entry, it contains the submatrix E(k) of full column +C rank to be reduced to upper triangular form. +C On return, it contains the transformed matrix E(k). +C Q - DOUBLE PRECISION array of dimension (LDQ,M). +C On entry, Q contains the row transformations corresponding +C to the input matrices A and E. +C On return, it contains the product of the input matrix Q and +C the row transformation matrix that has transformed the rows +C of the matrices A and E. +C M - INTEGER. +C Number of rows of A and E. (1 <= M <= LDA). +C N - INTEGER. +C Number of columns of A and E. (N >= 1). +C NRE - INTEGER +C Number of rows in E to be transformed (1 <= NRE <= M). +C NCE - INTEGER. +C Number of columns in E to be transformed (1 <= NCE <= N). +C IFIRE - INTEGER. +C Index of first row in E to be transformed. +C IFICE - INTEGER. +C Index of first column in E to be transformed. +C IFICA - INTEGER. +C Index of first column in A to be transformed. +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, Ph.D.Thesis, Eindhoven University of +C Technology, The Netherlands, 1987. +C +C CONTRIBUTOR: Th.G.J. Beelen (Philips Glas Eindhoven) +C +C REVISIONS: 1988, January 29. +C +C Specification of the parameters. +C +C .. Scalar arguments .. +C + INTEGER LDA, LDQ, M, N, NRE, NCE, IFIRE, IFICE, IFICA +C +C .. Array arguments .. +C + DOUBLE PRECISION A(LDA,N), E(LDA,N), Q(LDQ,M) +C +C EXTERNAL SUBROUTINES: +C +C DROT from BLAS +C DGIV from SLICOT. +C +C Local variables. +C + DOUBLE PRECISION SC, SS + INTEGER I, II, IIPVT, J, JJ, IFICE1, IFIRE1, NELM +C + IFIRE1 = IFIRE - 1 + IFICE1 = IFICE - 1 +C + DO 20 J = 1, NCE + JJ = IFICE1 + J + IIPVT = IFIRE1 + J + DO 10 I = J + 1, NRE + II = IFIRE1 + I +C +C Determine the Givens transformation on rows ii and iipvt. +C Apply the transformation to these rows (in whole E-matrix) +C to annihilate E(ii,jj) (from columns jj 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. +C + CALL DGIV(E(IIPVT,JJ), E(II,JJ), SC, SS) + NELM = N - JJ + 1 + CALL DROT(NELM, E(IIPVT,JJ), LDA, E(II,JJ), LDA, SC, SS) + E(II,JJ) = 0.0D0 + NELM = N - IFICA + 1 + CALL DROT(NELM, A(IIPVT,IFICA), LDA, A(II,IFICA), LDA, + * SC, SS) + CALL DROT(M, Q(IIPVT,1), LDQ, Q(II,1), LDQ, SC, SS) + 10 CONTINUE + 20 CONTINUE +C + RETURN +C *** Last line of TRIAEK ********************************************* + END +** END OF TRIAEKTEXT +*UPTODATE TRIREDTEXT + SUBROUTINE TRIRED(A, LDA, E, Q, LDQ, Z, LDZ, M, N, NBLCKS, + * INUK, IMUK, IERR) +C +C PURPOSE: +C +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 trans- +C formations (see Algorithm 3.2.1 in [1]), i.e., +C +C | s*E(eps,inf)-A(eps,inf) | X | +C s*E - A = |-------------------------|-------------| . +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 Subroutine TRIRED performs the triangularization of the sub- +C matrices having full row and column rank in the pencil +C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.1 in [1]. +C REMARK: This routine is intended to be called only from the +C SLICOT routine FSTAIR. +C +C PARAMETERS: +C +C A - DOUBLE PRECISION array of dimension (LDA,N). +C On entry, it contains the matrix A to be reduced. +C On return, it contains the transformed matrix A. +C E - DOUBLE PRECISION array of dimension (LDA,N). +C On entry, it contains the matrix E to be reduced. +C On return, it contains the transformed matrix E. +C Q - DOUBLE PRECISION array of dimension (LDQ,M). +C On entry, Q contains the row transformations corresponding +C to the input matrices A and E. +C On return, it contains the product of the input matrix Q and +C the row transformation matrix that has transformed the rows +C of the matrices A and E. +C Z - DOUBLE PRECISION array of dimension (LDZ,N). +C On entry, Z contains the column transformations corresponding +C to the input matrices A and E. +C On return, it contains the product of the input matrix Z and +C the column transformation matrix that has transformed the +C columns of the matrices A and E. +C M - INTEGER. +C Number of rows in A and E, 1 <= M <= LDA. +C N - INTEGER. +C Number of columns in A and E, N >= 1. +C NBLCKS - INTEGER. +C Number of submatrices having full row rank >=0 in A(eps,inf). +C INUK - INTEGER array of dimension (NBLCKS). +C Array containing the row dimensions nu(k) (k=1,..,NBLCKS) +C of the submatrices having full row rank in the pencil +C s*E(eps,inf)-A(eps,inf). +C IMUK - INTEGER array of dimension (NBLCKS). +C Array containing the column dimensions mu(k) (k=1,..,NBLCKS) +C of the submatrices having full column rank in the pencil. +C IERR - INTEGER. +C IERR = 0, successful completion, +C 1, incorrect dimensions of a full row rank submatrix, +C 2, incorrect dimensions of a full column rank submatrix +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, Ph.D.Thesis, Eindhoven University of +C Technology, The Netherlands, 1987. +C +C CONTRIBUTOR: Th.G.J. Beelen (Philips Glas Eindhoven) +C +C REVISIONS: 1988, January 29. +C +C Specification of the parameters. +C +C .. Scalar arguments .. +C + INTEGER LDA, LDQ, LDZ, M, N, NBLCKS, IERR +C +C .. Array arguments .. +C + DOUBLE PRECISION A(LDA,N), E(LDA,N), Q(LDQ,M), Z(LDZ,N) + INTEGER INUK(NBLCKS), IMUK(NBLCKS) +C +C EXTERNAL SUBROUTINES: +C +C TRIAAK, TRIAEK from SLICOT. +C +C Local variables. +C + INTEGER ISMUK, ISNUK1, IFIRA, IFICA, IFIRE, IFICE + INTEGER I, K, MUK, MUKP1, NUK +C +C ISMUK = sum(i=1,...,k) MU(i), +C ISNUK1 = sum(i=1,...,k-1) NU(i). +C + ISMUK = 0 + ISNUK1 = 0 + DO 10 I = 1, NBLCKS + ISMUK = ISMUK + IMUK(I) + ISNUK1 = ISNUK1 + INUK(I) + 10 CONTINUE +C +C NOTE: ISNUK1 has not yet the correct value. +C + IERR = 0 + MUKP1 = 0 + DO 20 K = NBLCKS, 1, -1 + MUK = IMUK(K) + NUK = INUK(K) + ISNUK1 = ISNUK1 - NUK +C +C Determine left upper absolute coordinates of E(k) in E-matrix. +C + IFIRE = 1 + ISNUK1 + IFICE = 1 + ISMUK +C +C Determine left upper absolute coordinates of A(k) in A-matrix. +C + IFIRA = IFIRE + 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 + IERR = 1 + RETURN + END IF +C + CALL TRIAEK(A, LDA, E, Q, LDQ, M, N, NUK, MUKP1, IFIRE, IFICE, + * IFICA) +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 + IERR = 2 + RETURN + END IF +C + CALL TRIAAK(A, LDA, E, Z, LDZ, N, NUK, MUK, IFIRA, IFICA) +C + ISMUK = ISMUK - MUK + MUKP1 = MUK + 20 CONTINUE +C + RETURN +C *** Last line of TRIRED ********************************************* + END + SUBROUTINE BAE(A, LDA, E, Q, LDQ, Z, LDZ, M, N, ISTAIR, IFIRA, + * IFICA, NCA, RANK, WRK, IWRK, TOL) +C +C LIBRARY INDEX: +C +C +C +C PURPOSE: +C +C Let A and E be M x 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 The subroutine BAE transforms (AA,EE) such that Aj is row +C compressed while keeping matrix Ej in column echelon form +C (which may be different from the form on entry). +C In fact BAE performs the j-th step of Algorithm 3.2.1 in [1]. +C Furthermore, BAE determines the rank RANK of the submatrix Ej. +C This is equal to the number of corner points in submatrix Ej. +C REMARK: This routine is intended to be called only from the +C SLICOT routine FSTAIR. +C +C PARAMETERS: +C +C A - DOUBLE PRECISION array of DIMENSION (LDA,N). +C On entry, A(IFIRA : M ; IFICA : IFICA + NCA -1) contains the +C matrix AA. +C On return, it contains the matrix AA that has been row com- +C pressed while keeping EE in column echelon form. +C LDA - INTEGER. +C LDA is the leading dimension of the arrays A and E. LDA >= M. +C E - DOUBLE PRECISION array of DIMENSION (LDA,N). +C On entry, E(IFIRA : M ; IFICA + NCA : N) contains the matrix +C EE which is in column echelon form. +C On return, it contains the transformed matrix EE which is kept +C in column echelon form. +C Q - DOUBLE PRECISION array of DIMENSION (LDQ,M). +C On entry, the array Q contains the row transformations +C corresponding to the input matrices A and E. +C On return, it contains the M x M unitary matrix Q which is the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A and E. +C LDQ - INTEGER. +C LDQ is the leading dimension of the matrix Q. LDQ >= M. +C Z - DOUBLE PRECISION array of DIMENSION (LDZ,N). +C On entry, the array Z contains the column transformations +C corresponding to the input matrices A and E. +C On return, it contains the N x N unitary matrix Z which is the +C product of the input matrix Z and the column transformation +C matrix that has transformed the columns of A and E. +C LDZ - INTEGER. +C LDZ is the leading dimension of the matrix Z. LDZ >= N. +C M - INTEGER. +C M is the number of rows of the matrices A, E and Q. M >= 1. +C N - INTEGER. +C N is the number of columns of the matrices A, E and Z. N >= 1. +C ISTAIR - INTEGER array of DIMENSION (M). +C On entry, ISTAIR contains information on the column echelon +C form of the input matrix E as follows: +C ISTAIR(i) = + j: the boundary element E(i,j) is a corner point +C - j: the boundary element E(i,j) is not a corner +C point. +C (i=1,...,M) +C On return, ISTAIR contains the same information for the trans- +C formed matrix E. +C IFIRA - INTEGER. +C IFIRA is the first row index of the submatrix Aj and Ej in +C matrix A and E, respectively. +C IFICA - INTEGER. +C IFICA and IFICA + NCA are the first column index of the +C submatrices Aj and Ej in the matrices A and E, respectively. +C NCA - INTEGER. +C NCA is the number of columns of the submatrix Aj in A. +C RANK - INTEGER. +C Numerical rank of the submatrix Ej in E (based on TOL). +C WRK - DOUBLE PRECISION array of DIMENSION (N). +C A real work space array. +C IWRK - INTEGER array of DIMENSION (N). +C An integer work space array. +C TOL - DOUBLE PECISION. +C TOL is the tolerance used when considering matrix elements to +C be zero. TOL should be set to RE * max(||A||,||E||) + AE, +C where ||.|| is the Frobenius norm. AE and RE are the absolute +C and relative accuracy respectively. +C A recommanded choice is AE = EPS and RE = 100*EPS, where EPS +C is the machine precision. +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, Ph.D.Thesis, Eindhoven University of +C Technology, The Netherlands, 1987. +C +C CONTRIBUTOR: Th.G.J. Beelen (Philips Glass Eindhoven). +C +C REVISIONS: 1988, January 29. +C +C Specification of the parameters. +C +C .. Scalar arguments .. +C + INTEGER LDA, LDQ, LDZ, M, N, IFIRA, IFICA, NCA, RANK + DOUBLE PRECISION TOL +C +C .. Array arguments .. +C + INTEGER ISTAIR(M), IWRK(N) + DOUBLE PRECISION A(LDA,N), E(LDA,N), Q(LDQ,M), Z(LDZ,N), WRK(N) +C +C EXTERNAL SUBROUTINES/FUNCTIONS: +C +C IDAMAX, DROT, DSWAP from BLAS. +C DGIV from SLICOT. +C +C Local variables. +C + INTEGER I, II, IMX, IP, IR, IST1, IST2, ISTPVT, ITYPE, + * IFIRA1, IFICA1, JPVT, JC1, JC2, NROWS, + * K, K1, KK, L, LSAV, LL, MK1, MXRANK, NELM, MJ, NJ + DOUBLE PRECISION BMXNRM, BMX, SC, SS, EIJPVT + LOGICAL LZERO +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 + DO 10 I = 1, NJ + IWRK(I) = I + 10 CONTINUE + K = 1 + LZERO = .FALSE. + RANK = MIN0(NJ,MJ) + MXRANK = RANK +C +C WHILE (K <= MXRANK) and (LZERO = FALSE) DO + 20 IF ((K .LE. MXRANK) .AND. (.NOT.LZERO)) THEN +C +C Determine column in Aj with largest max-norm. +C + BMXNRM = 0.0D0 + LSAV = K + DO 30 L = K, NJ +C +C IMX is relative index in column L of Aj where max el. is +C found. +C NOTE: the first el. in column L is in row K of matrix Aj. +C + KK = IFIRA1 + K + LL = IFICA1 + L + IMX = IDAMAX(MJ - K + 1, A(KK,LL), 1) + BMX = DABS(A(IMX + KK - 1, LL)) + IF (BMX .GT. BMXNRM) THEN + BMXNRM = BMX + LSAV = L + END IF + 30 CONTINUE +C + IF (BMXNRM .LT. TOL) THEN +C +C Set submatrix of Aj to zero. +C + DO 50 L = K, NJ + LL = IFICA1 + L + DO 40 I = K, MJ + II = IFIRA1 + I + A(II,LL) = 0.0D0 + 40 CONTINUE + 50 CONTINUE + 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 IWRK. +C + CALL DSWAP(M, A(1,IFICA1 + K), 1, A(1,IFICA1 + LSAV), 1) + IP = IWRK(LSAV) + IWRK(LSAV) = IWRK(K) + IWRK(K) = IP + END IF +C + K1 = K + 1 + MK1 = NJ - K + 1 + (N - NCA - IFICA1) + KK = IFICA1 + K +C + DO 90 IR = K1, MJ +C + I = MJ - IR + K1 +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. +C + CALL DGIV(A(II - 1,KK), A(II,KK), SC, SS) + CALL DROT(MK1, A(II - 1,KK), LDA, A(II,KK), LDA, SC, SS) + A(II,KK) = 0.0D0 + CALL DROT(M, Q(II - 1,1), LDQ, Q(II,1), LDQ, 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 = IABS(IST1) + JC2 = IABS(IST2) + JPVT = MIN0(JC1,JC2) + NELM = N - JPVT + 1 +C + CALL DROT(NELM, E(II-1,JPVT), LDA, E(II,JPVT), LDA, + * SC, SS) + EIJPVT = E(II,JPVT) +C + GOTO (80, 60, 90, 70), ITYPE +C + 60 IF (DABS(EIJPVT) .LT. TOL) THEN +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) = 0.0D0 + END IF + GOTO 90 +C + 70 IF (DABS(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 + GOTO 90 +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 + 80 CALL DGIV(E(II,JPVT + 1), E(II,JPVT), SC, SS) + CALL DROT(II, E(1,JPVT + 1), 1, E(1,JPVT), 1, SC, SS) + E(II,JPVT) = 0.0D0 +C +C Apply this transformation also to matrix A. +C (NOT only to Aj). +C Update column transformation matrix Z. +C + CALL DROT(M, A(1,JPVT + 1), 1, A(1,JPVT), 1, SC, SS) + CALL DROT(N, Z(1,JPVT + 1), 1, Z(1,JPVT), 1, SC, SS) +C + 90 CONTINUE +C + K = K + 1 + END IF + GOTO 20 + END IF +C END WHILE 20 +C +C Permute columns of Aj to original order. +C + NROWS = IFIRA1 + RANK + DO 120 I = 1, NROWS + DO 100 K = 1, NJ + KK = IFICA1 + K + WRK(IWRK(K)) = A(I,KK) + 100 CONTINUE + DO 110 K = 1, NJ + KK = IFICA1 + K + A(I,KK) = WRK(K) + 110 CONTINUE + 120 CONTINUE +C + RETURN +C *** Last line of BAE ************************************************ + END +** END OF BAETEXT +*UPTODATE DGIVTEXT + SUBROUTINE DGIV(DA, DB, DC, DS) +C +C LIBRARY INDEX: +C +C 2.1.4 Decompositions and transformations. +C +C PURPOSE: +C +C This routine constructs the Givens transformation +C +C ( DC DS ) +C G = ( ), DC**2 + DS**2 = 1.0D0 , +C (-DS DC ) +C T T +C such that the vector (DA,DB) is transformed into (R,0), i.e., +C +C ( DC DS ) ( DA ) ( R ) +C ( ) ( ) = ( ) +C (-DS DC ) ( DB ) ( 0 ) . +C +C This routine is a modification of the BLAS routine DROTG +C (Algorithm 539) in order to leave the arguments DA and DB +C unchanged. The value or R is not returned. +C +C CONTRIBUTOR: P. Van Dooren (PRLB). +C +C REVISIONS: 1987, November 24. +C +C Specification of parameters. +C +C .. Scalar Arguments .. +C + DOUBLE PRECISION DA, DB, DC, DS +C +C Local variables. +C + DOUBLE PRECISION R, U, V +C + IF (DABS(DA) .GT. DABS(DB)) THEN + U = DA + DA + V = DB/U + R = DSQRT(0.25D0 + V**2) * U + DC = DA/R + DS = V * (DC + DC) + ELSE + IF (DB .NE. 0.0D0) THEN + U = DB + DB + V = DA/U + R = DSQRT(0.25D0 + V**2) * U + DS = DB/R + DC = V * (DS + DS) + ELSE + DC = 1.0D0 + DS = 0.0D0 + END IF + END IF + RETURN +C *** Last line of DGIV *********************************************** + END +** END OF DGIVTEXT +*UPTODATE DROTITEXT + SUBROUTINE DROTI (N, X, INCX, Y, INCY, C, S) +C +C LIBRARY INDEX: +C +C 2.1.4 Decompositions and transfromations. +C +C PURPOSE: +C +C The subroutine DROTI performs the Givens transformation, defined +C by C (cos) and S (sin), and interchanges the vectors involved, +C 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 +C CONTRIBUTOR: Th.G.J. Beelen (Philips Glass Eindhoven) +C +C REVISIONS: 1988, February 02. +C +C Specification of the parameters. +C +C .. Scalar argumants .. +C + INTEGER INCX, INCY, N + DOUBLE PRECISION C, S +C +C .. Array arguments .. +C + DOUBLE PRECISION X(*), Y(*) +C +C Local variables. +C + DOUBLE PRECISION DTEMP + INTEGER I, IX, IY +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 + DO 10 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 + 10 CONTINUE + ELSE +C +C Code for both increments equal to 1. +C + DO 20 I = 1, N + DTEMP = C * Y(I) - S * X(I) + Y(I) = C * X(I) + S * Y(I) + X(I) = DTEMP + 20 CONTINUE + END IF + RETURN +C *** Last line if DROTI ********************************************** + END diff --git a/modules/cacsd/src/slicot/fstair.lo b/modules/cacsd/src/slicot/fstair.lo new file mode 100755 index 000000000..92aedf36a --- /dev/null +++ b/modules/cacsd/src/slicot/fstair.lo @@ -0,0 +1,12 @@ +# src/slicot/fstair.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fstair.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01ad.f b/modules/cacsd/src/slicot/ib01ad.f new file mode 100755 index 000000000..1cb993f05 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01ad.f @@ -0,0 +1,670 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 2000. +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, 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, 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. +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 + 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 + 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, if METH = 'N'; +C prefer larger. +C + CALL IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, RCOND, IWORK, + $ DWORK, LDWORK, IWARNL, INFO ) + IWARN = MAX( IWARN, IWARNL ) +C + IF ( INFO.EQ.2 ) THEN +C +C Error return: the singular value decomposition (SVD) algorithm +C did not converge. +C + RETURN + END IF +C +C Estimate the system order. +C + CALL IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARNL, INFO ) + IWARN = MAX( IWARN, IWARNL ) +C +C Return optimal workspace in DWORK(1). +C + DWORK( 1 ) = MAX( MAXWRK, INT( DWORK( 1 ) ) ) + RETURN +C +C *** Last line of IB01AD *** + END diff --git a/modules/cacsd/src/slicot/ib01ad.lo b/modules/cacsd/src/slicot/ib01ad.lo new file mode 100755 index 000000000..fb20a06c9 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01ad.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01ad.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01ad.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01bd.f b/modules/cacsd/src/slicot/ib01bd.f new file mode 100755 index 000000000..8bf2bb89f --- /dev/null +++ b/modules/cacsd/src/slicot/ib01bd.f @@ -0,0 +1,774 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 2000. +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 + max( 3*L*NOBR, 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), 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), 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. +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 IF( LDWORK.GE.1 ) THEN +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, 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, ID + MNOBRN + NPL ) + IF( .NOT.MOESP .AND. M.GT.0 .AND. WITHB ) + $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + + $ MAX( NPL**2, 4*M*NPL + 1 ) ) + MINWRK = LNOBR*N + MINWRK + END IF +C + IF( WITHK ) THEN + MINWRK = MAX( MINWRK, 4*NN + 2*NL + LL + MAX( 3*L, NL ), + $ 14*NN + 12*N + 5 ) + END IF +C + IF ( LDWORK.LT.MINWRK ) THEN + INFO = -30 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01BD', -INFO ) + RETURN + END IF +C + IF ( .NOT.WITHK ) THEN + JOBCV = JOBCK + ELSE + JOBCV = 'C' + END IF +C + IO = 1 + IF ( .NOT.MOESP .OR. WITHCO ) THEN + JWORK = IO + LNOBR*N + ELSE + JWORK = IO + END IF + MAXWRK = MINWRK +C +C Call the computational routine for estimating system matrices. +C + IF ( .NOT.COMBIN ) THEN + CALL IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, LDR, + $ A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, RY, LDRY, + $ S, LDS, DWORK(IO), LNOBR, TOL, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARN, INFO ) +C + ELSE +C + IF ( WITHC ) THEN + IF ( WITHAL ) THEN + JOBCOV = 'N' + ELSE + JOBCOV = JOBCV + END IF + CALL IB01PD( 'MOESP', 'C and A', JOBCOV, NOBR, N, M, L, + $ NSMPL, R, LDR, A, LDA, C, LDC, B, LDB, D, LDD, + $ Q, LDQ, RY, LDRY, S, LDS, DWORK(IO), LNOBR, + $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, + $ IWARNL, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + IWARN = MAX( IWARN, IWARNL ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C + IF ( WITHB ) THEN + IF ( .NOT.WITHAL ) THEN + JOBBD = JOB + ELSE + JOBBD = 'D' + END IF + CALL IB01PD( 'N4SID', JOBBD, JOBCV, NOBR, N, M, L, NSMPL, R, + $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, + $ RY, LDRY, S, LDS, DWORK(IO), LNOBR, TOL, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFO ) + IWARN = MAX( IWARN, IWARNL ) + END IF + END IF +C + IF ( INFO.NE.0 ) + $ RETURN + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + DO 10 I = 1, 4 + RCND(I) = DWORK(JWORK+I) + 10 CONTINUE +C + IF ( WITHK ) THEN + IF ( IWARN.EQ.5 ) THEN +C +C The problem seems to be a deterministic one. Set the Kalman +C gain to zero, set accuracy parameters and return. +C + CALL DLASET( 'Full', N, L, ZERO, ZERO, K, LDK ) +C + DO 20 I = 6, 12 + DWORK(I) = ONE + 20 CONTINUE +C + DWORK(13) = ZERO + ELSE +C +C Compute the Kalman gain matrix. +C +C Convert the optimal problem with coupling weighting terms +C to a standard problem. +C Workspace: need 4*N*N+2*N*L+L*L+max( 3*L,N*L ); +C prefer larger. +C + IX = 1 + IQ = IX + NN + IA = IQ + NN + IG = IA + NN + IC = IG + NN + IR = IC + NL + IS = IR + LL + JWORK = IS + NL +C + CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) + CALL DLACPY( 'Upper', N, N, Q, LDQ, DWORK(IQ), N ) + CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) + CALL DLACPY( 'Full', N, L, S, LDS, DWORK(IS), N ) +C + CALL SB02MT( 'G needed', 'Nonzero S', 'Not factored', + $ 'Upper', N, L, DWORK(IA), N, DWORK(IC), N, + $ DWORK(IQ), N, DWORK(IR), L, DWORK(IS), N, + $ IWORK, IFACT, DWORK(IG), N, IWORK(L+1), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + RCONDR = DWORK(JWORK+1) +C +C Solve the Riccati equation. +C Workspace: need 14*N*N+12*N+5; +C prefer larger. +C + IT = IC + IV = IT + NN + IWR = IV + NN + IWI = IWR + N2 + IS = IWI + N2 + JWORK = IS + N2*N2 +C + CALL SB02RD( 'All', 'Discrete', 'Direct', 'NoTranspose', + $ 'Upper', 'General scaling', 'Unstable first', + $ 'Not factored', 'Reduced', N, DWORK(IA), N, + $ DWORK(IT), N, DWORK(IV), N, DWORK(IG), N, + $ DWORK(IQ), N, DWORK(IX), N, SEP, RCOND, FERR, + $ DWORK(IWR), DWORK(IWI), DWORK(IS), N2, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, BWORK, IERR ) +C + IF ( IERR.NE.0 .AND. IERR.LT.7 ) THEN + INFO = IERR + 3 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + DO 30 I = 1, 4 + RCND(I+4) = DWORK(JWORK+I) + 30 CONTINUE +C +C Compute the gain matrix. +C Workspace: need 2*N*N+2*N*L+L*L+3*L; +C prefer larger. +C + IA = IX + NN + IC = IA + NN + IR = IC + NL + IK = IR + LL + JWORK = IK + NL +C + CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) + CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) +C + CALL SB02ND( 'Discrete', 'NotFactored', 'Upper', + $ 'Nonzero S', N, L, 0, DWORK(IA), N, DWORK(IC), + $ N, DWORK(IR), L, IWORK, S, LDS, DWORK(IX), N, + $ RNORM, DWORK(IK), L, OUFACT, IWORK(L+1), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C + IF ( IERR.NE.0 ) THEN + IF ( IERR.LE.L+1 ) THEN + INFO = 3 + ELSE IF ( IERR.EQ.L+2 ) THEN + INFO = 10 + END IF + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + CALL MA02AD( 'Full', L, N, DWORK(IK), L, K, LDK ) +C +C Set the accuracy parameters. +C + DWORK(11) = DWORK(JWORK+1) +C + DO 40 I = 6, 9 + DWORK(I) = RCND(I-1) + 40 CONTINUE +C + DWORK(10) = RCONDR + DWORK(12) = RCOND + DWORK(13) = FERR + END IF + END IF +C +C Return optimal workspace in DWORK(1) and the remaining +C reciprocal condition numbers in the next locations. +C + DWORK(1) = MAXWRK +C + DO 50 I = 2, 5 + DWORK(I) = RCND(I-1) + 50 CONTINUE +C + RETURN +C +C *** Last line of IB01BD *** + END diff --git a/modules/cacsd/src/slicot/ib01bd.lo b/modules/cacsd/src/slicot/ib01bd.lo new file mode 100755 index 000000000..a19a11d75 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01bd.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01bd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01bd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01cd.f b/modules/cacsd/src/slicot/ib01cd.f new file mode 100755 index 000000000..e6c377cb5 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01cd.f @@ -0,0 +1,807 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 2000. +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 DLAPY2 + EXTERNAL DLAPY2, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, IB01QD, IB01RD, + $ TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C +C Check the input parameters. +C + WITHX0 = LSAME( JOBX0, 'X' ) + COMPBD = LSAME( COMUSE, 'C' ) + USEBD = LSAME( COMUSE, 'U' ) + WITHD = LSAME( JOB, 'D' ) + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + MAXDIM = ( WITHX0 .AND. USEBD ) .OR. COMPBD + MAXDIA = WITHX0 .OR. COMPBD +C + IWARN = 0 + INFO = 0 + LDW = MAX( 1, N ) + LM = L*M + LN = L*N + NN = N*N + NM = N*M + N2M = N*NM + IF( COMPBD ) THEN + NCOL = NM + IF( WITHX0 ) + $ NCOL = NCOL + N + MINSMP = NCOL + IF( WITHD ) THEN + MINSMP = MINSMP + M + IQ = MINSMP + ELSE IF ( .NOT.WITHX0 ) THEN + IQ = MINSMP + MINSMP = MINSMP + 1 + ELSE + IQ = MINSMP + END IF + ELSE + NCOL = N + IF( WITHX0 ) THEN + MINSMP = N + ELSE + MINSMP = 0 + END IF + IQ = MINSMP + END IF +C + IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( COMPBD .OR. USEBD .OR. LSAME( COMUSE, 'N' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.WITHB ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LE.0 ) THEN + INFO = -6 + ELSE IF( NSMP.LT.MINSMP ) THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. ( MAXDIA .AND. LDA.LT.LDW ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDB.LT.LDW ) ) + $ THEN + INFO = -11 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. MAXDIA .AND. LDC.LT.L ) ) + $ THEN + INFO = -13 + ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. WITHD .AND. + $ LDD.LT.L ) ) THEN + INFO = -15 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDU.LT.NSMP ) ) + $ THEN + INFO = -17 + ELSE IF( LDY.LT.1 .OR. ( MAXDIA .AND. LDY.LT.NSMP ) ) THEN + INFO = -19 + ELSE IF( LDV.LT.1 .OR. ( MAXDIA .AND. LDV.LT.LDW ) ) THEN + INFO = -22 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -23 + END IF +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN + MINWRK = 2 + ELSE + NSMPL = NSMP*L + IQ = IQ*L + NCP1 = NCOL + 1 + ISIZE = NSMPL*NCP1 + IF ( COMPBD ) THEN + IF ( N.GT.0 .AND. WITHX0 ) THEN + IC = 2*NN + N + ELSE + IC = 0 + END IF + ELSE + IC = 2*NN + END IF + MINWLS = NCOL*NCP1 + IF ( COMPBD ) THEN + IF ( WITHD ) + $ MINWLS = MINWLS + LM*NCP1 + IF ( M.GT.0 .AND. WITHD ) THEN + IA = M + MAX( 2*NCOL, M ) + ELSE + IA = 2*NCOL + END IF + ITAU = N2M + MAX( IC, IA ) + IF ( WITHX0 ) + $ ITAU = ITAU + LN + LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) + LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) + IF ( M.GT.0 .AND. WITHD ) THEN + LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) + LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) + IA = 3 + ELSE + IA = 2 + END IF + ELSE + ITAU = IC + LN + LDW2 = ISIZE + 2*N + MAX( IC, 4*N ) + LDW3 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) + IA = 2 + END IF + MINWRK = IA + NN + NM + LN + MAX( 5*N, IA, MIN( LDW2, LDW3 ) ) +C + IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN + MAXWRK = MAX( 5*N, IA ) + IF ( COMPBD ) THEN + IF ( M.GT.0 .AND. WITHD ) THEN + MAXWRK = MAX( MAXWRK, ISIZE + N + M + + $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, + $ M, -1, -1 ), + $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', + $ ' ', NSMP-M, NCOL, -1, -1 ) ) ) + MAXWRK = MAX( MAXWRK, ISIZE + N + M + + $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', + $ NSMP, NCP1, M, -1 ), + $ NCOL + ILAENV( 1, 'DORMQR', 'LT', + $ NSMP-M, 1, NCOL, -1 ) ) ) + ELSE + MAXWRK = MAX( MAXWRK, ISIZE + N + NCOL + + $ MAX( NCOL*ILAENV( 1, 'DGEQRF', + $ ' ', NSMPL, NCOL, -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT', + $ NSMPL, 1, NCOL, -1 ) ) ) + END IF + ELSE + MAXWRK = MAX( MAXWRK, ISIZE + 2*N + + $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', + $ NSMPL, N, -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT', + $ NSMPL, 1, N, -1 ) ) ) + END IF + MAXWRK = IA + NN + NM + LN + MAXWRK + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + END IF +C + IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN + INFO = -26 + DWORK(1) = MINWRK + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN + DWORK(2) = ONE + IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) THEN + DWORK(1) = THREE + DWORK(3) = ONE + ELSE + DWORK(1) = TWO + END IF + IF ( N.GT.0 .AND. USEBD ) THEN + DUM(1) = ZERO + CALL DCOPY( N, DUM, 0, X0, 1 ) + END IF + RETURN + END IF +C +C Compute the Schur factorization of A and transform the other +C given system matrices accordingly. +C Workspace: need g + N*N + L*N + N*M + 5*N, where +C g = 2, if M = 0, COMUSE = 'C', or JOB = 'B', +C g = 3, if M > 0, COMUSE = 'C', and JOB = 'D', +C g = 2, if JOBX0 = 'X' and COMUSE <> 'C'; +C prefer larger. +C + IA = IA + 1 + IC = IA + NN + IB = IC + LN + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), LDW ) + CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IC), L ) +C + IF ( USEBD ) THEN + MTMP = M + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(IB), LDW ) + ELSE + MTMP = 0 + END IF + IWR = IB + NM + IWI = IWR + N + JWORK = IWI + N +C + CALL TB01WD( N, MTMP, L, DWORK(IA), LDW, DWORK(IB), LDW, + $ DWORK(IC), L, V, LDV, DWORK(IWR), DWORK(IWI), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 1 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) +C + DO 10 I = IWR, IWI - 1 + IF( DLAPY2( DWORK(I), DWORK(I+N) ).GE.ONE ) + $ IWARN = 6 + 10 CONTINUE +C + JWORK = IWR +C +C Estimate x(0) and/or the system matrices B and D. +C Workspace: need g + N*N + L*N + N*M + +C max( g, min( LDW2, LDW3 ) ) (see LDWORK); +C prefer larger. +C + IF ( COMPBD ) THEN + CALL IB01QD( JOBX0, JOB, N, M, L, NSMP, DWORK(IA), LDW, + $ DWORK(IC), L, U, LDU, Y, LDY, X0, DWORK(IB), LDW, + $ D, LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, + $ IWARNL, INFO ) +C + IF( INFO.EQ.0 ) THEN + IF ( M.GT.0 .AND. WITHD ) + $ RCONDU = DWORK(JWORK+2) +C +C Compute the system input matrix B corresponding to the +C original system. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, N, ONE, + $ V, LDV, DWORK(IB), LDW, ZERO, B, LDB ) + END IF + ELSE + IF ( WITHD ) THEN + JOBD = 'N' + ELSE + JOBD = 'Z' + END IF +C + CALL IB01RD( JOBD, N, MTMP, L, NSMP, DWORK(IA), LDW, DWORK(IB), + $ LDW, DWORK(IC), L, D, LDD, U, LDU, Y, LDY, X0, + $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARNL, + $ INFO ) + END IF + IWARN = MAX( IWARN, IWARNL ) +C + IF( INFO.EQ.0 ) THEN + RCOND = DWORK(JWORK+1) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF( WITHX0 ) THEN +C +C Transform the initial state estimate to obtain the initial +C state corresponding to the original system. +C Workspace: need g + N*N + L*N + N*M + N. +C + CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, X0, 1, ZERO, + $ DWORK(JWORK), 1 ) + CALL DCOPY( N, DWORK(JWORK), 1, X0, 1 ) + END IF +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND + IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) + $ DWORK(3) = RCONDU + END IF + RETURN +C +C *** End of IB01CD *** + END diff --git a/modules/cacsd/src/slicot/ib01cd.lo b/modules/cacsd/src/slicot/ib01cd.lo new file mode 100755 index 000000000..2d81aafed --- /dev/null +++ b/modules/cacsd/src/slicot/ib01cd.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01cd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01cd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01md.f b/modules/cacsd/src/slicot/ib01md.f new file mode 100755 index 000000000..bb6d394ff --- /dev/null +++ b/modules/cacsd/src/slicot/ib01md.f @@ -0,0 +1,1411 @@ + SUBROUTINE IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, + $ LDU, Y, LDY, R, LDR, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +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. +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 I = 1, M + L + CALL DCOPY( NOBR21, DWORK(IREV), -1, DWORK(ICOL), -1 ) + 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 I = 1, L + CALL DCOPY( NOBR21, DWORK(IREV), -1, DWORK(ICOL), -1 ) + 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 I = 1, M + CALL DCOPY( NOBR21, DWORK(IREV), -1, DWORK(ICOL), -1 ) + IREV = IREV - NOBR21 + ICOL = ICOL - LDRWRK + 390 CONTINUE +C + IF( MOESP ) + $ CALL DLACPY( 'Full', NOBRM1, M, DWORK(INU+NOBR), LDRWRK, + $ DWORK, LDRWRK ) + END IF +C +C Data compression using QR factorization. +C + IF ( FIRST ) THEN +C +C Non-sequential data processing or first block in +C sequential data processing: +C Use the general QR factorization algorithm. +C + IF ( LINR ) THEN +C +C Put the input-output data in the array R. +C + IF( M.GT.0 ) THEN + IF( MOESP ) THEN +C + DO 400 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, + $ R(1,M*(I-1)+1), LDR ) + 400 CONTINUE +C + DO 410 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ R(1,MNOBR+M*(I-1)+1), LDR ) + 410 CONTINUE +C + ELSE +C + DO 420 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ R(1,M*(I-1)+1), LDR ) + 420 CONTINUE +C + END IF + END IF +C + DO 430 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, + $ R(1,MMNOBR+L*(I-1)+1), LDR ) + 430 CONTINUE +C +C Workspace: need 4*(M+L)*NOBR, +C prefer 2*(M+L)*NOBR+2*(M+L)*NOBR*NB. +C + ITAU = 1 + JWORK = ITAU + NR + CALL DGEQRF( NS, NR, R, LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + ELSE +C +C Put the input-output data in the array DWORK. +C + IF( M.GT.0 ) THEN + ISHFTU = 1 + IF( MOESP ) THEN + ISHFT2 = INU +C + DO 440 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 440 CONTINUE +C + DO 450 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ DWORK(ISHFT2), LDRWRK ) + ISHFT2 = ISHFT2 + MLDRW + 450 CONTINUE +C + ELSE +C + DO 460 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 460 CONTINUE +C + END IF + END IF +C + ISHFTY = INY +C + DO 470 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, + $ DWORK(ISHFTY), LDRWRK ) + ISHFTY = ISHFTY + LLDRW + 470 CONTINUE +C +C Workspace: need 2*(M+L)*NOBR + 4*(M+L)*NOBR, +C prefer NS*2*(M+L)*NOBR + 2*(M+L)*NOBR +C + 2*(M+L)*NOBR*NB, +C used LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, +C where NS = NSMP - 2*NOBR + 1, +C LDRWRK = min(NS, LDWORK/(2*(M+L)*NOBR)-2). +C + ITAU = LDRWRK*NR + 1 + JWORK = ITAU + NR + CALL DGEQRF( NS, NR, DWORK, LDRWRK, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + CALL DLACPY( 'Upper ', MIN(NS,NR), NR, DWORK, LDRWRK, R, + $ LDR ) + END IF +C + IF ( NS.LT.NR ) + $ CALL DLASET( 'Upper ', NR - NS, NR - NS, ZERO, ZERO, + $ R(NS+1,NS+1), LDR ) + INITI = INITI + NS + END IF +C + IF ( NCYCLE.GT.1 .OR. .NOT.FIRST ) THEN +C +C Remaining segments of the first data block or +C remaining segments/blocks in sequential data processing: +C Use a structure-exploiting QR factorization algorithm. +C + NSL = LDRWRK + IF ( .NOT.CONNEC ) NSL = NS + ITAU = LDRWRK*NR + 1 + JWORK = ITAU + NR +C + DO 560 NICYCL = INICYC, NCYCLE +C +C INIT denotes the beginning row where new data are put. +C + IF ( CONNEC .AND. NICYCL.EQ.1 ) THEN + INIT = NOBR2 + ELSE + INIT = 1 + END IF + IF ( NCYCLE.GT.1 .AND. NICYCL.EQ.NCYCLE ) THEN +C +C Last samples in the last data segment of a block. +C + NS = NSLAST + NSL = NSLAST + END IF +C +C Put the input-output data in the array DWORK. +C + NSF = NS + IF ( INIT.GT.1 .AND. NCYCLE.GT.1 ) NSF = NSF - NOBR21 + IF ( M.GT.0 ) THEN + ISHFTU = INIT +C + IF( MOESP ) THEN + ISHFT2 = INIT + INU - 1 +C + DO 480 I = 1, NOBR + CALL DLACPY( 'Full', NSF, M, U(INITI+NOBR+I,1), + $ LDU, DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 480 CONTINUE +C + DO 490 I = 1, NOBR + CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, + $ DWORK(ISHFT2), LDRWRK ) + ISHFT2 = ISHFT2 + MLDRW + 490 CONTINUE +C + ELSE +C + DO 500 I = 1, NOBR2 + CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 500 CONTINUE +C + END IF + END IF +C + ISHFTY = INIT + INY - 1 +C + DO 510 I = 1, NOBR2 + CALL DLACPY( 'Full', NSF, L, Y(INITI+I,1), LDY, + $ DWORK(ISHFTY), LDRWRK ) + ISHFTY = ISHFTY + LLDRW + 510 CONTINUE +C + IF ( INIT.GT.1 ) THEN +C +C Prepare the connection to the previous block of data +C in sequential processing. +C + IF( MOESP .AND. M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR, M, U, LDU, DWORK(NOBR), + $ LDRWRK ) +C +C Shift the elements from the connection to the previous +C block of data in sequential processing. +C + IF ( M.GT.0 ) THEN + ISHFTU = MLDRW + 1 +C + IF( MOESP ) THEN + ISHFT2 = MLDRW + INU +C + DO 520 I = 1, NOBRM1 + CALL DLACPY( 'Full', NOBR21, M, + $ DWORK(ISHFTU-MLDRW+1), LDRWRK, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 520 CONTINUE +C + DO 530 I = 1, NOBRM1 + CALL DLACPY( 'Full', NOBR21, M, + $ DWORK(ISHFT2-MLDRW+1), LDRWRK, + $ DWORK(ISHFT2), LDRWRK ) + ISHFT2 = ISHFT2 + MLDRW + 530 CONTINUE +C + ELSE +C + DO 540 I = 1, NOBR21 + CALL DLACPY( 'Full', NOBR21, M, + $ DWORK(ISHFTU-MLDRW+1), LDRWRK, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 540 CONTINUE +C + END IF + END IF +C + ISHFTY = LLDRW + INY +C + DO 550 I = 1, NOBR21 + CALL DLACPY( 'Full', NOBR21, L, + $ DWORK(ISHFTY-LLDRW+1), LDRWRK, + $ DWORK(ISHFTY), LDRWRK ) + ISHFTY = ISHFTY + LLDRW + 550 CONTINUE +C + END IF +C +C Workspace: need LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR. +C + CALL MB04OD( 'Full', NR, 0, NSL, R, LDR, DWORK, LDRWRK, + $ DUM, NR, DUM, NR, DWORK(ITAU), DWORK(JWORK) + $ ) + INITI = INITI + NSF + 560 CONTINUE +C + END IF +C + IF ( .NOT.LAST ) THEN + IF ( CONNEC ) THEN +C +C For sequential processing with connected data blocks, +C save the remaining ("connection") elements of U and Y +C in the first (M+L)*(2*NOBR-1) locations of DWORK. +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR21, M, U(INITI+1,1), LDU, + $ DWORK, NOBR21 ) + CALL DLACPY( 'Full', NOBR21, L, Y(INITI+1,1), LDY, + $ DWORK(MMNOBR-M+1), NOBR21 ) + END IF +C +C Return to get new data. +C + ICYCLE = ICYCLE + 1 + IF ( ICYCLE.LE.MAXCYC ) + $ RETURN + IWARN = 1 + ICYCLE = 1 +C + END IF +C + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK( 1 ) = MAXWRK + IF ( LAST ) THEN + ICYCLE = 1 + MAXWRK = 1 + NSMPSM = 0 + END IF + RETURN +C +C *** Last line of IB01MD *** + END diff --git a/modules/cacsd/src/slicot/ib01md.lo b/modules/cacsd/src/slicot/ib01md.lo new file mode 100755 index 000000000..ba9a3ca3d --- /dev/null +++ b/modules/cacsd/src/slicot/ib01md.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01md.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01md.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01my.f b/modules/cacsd/src/slicot/ib01my.f new file mode 100755 index 000000000..6777a92a2 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01my.f @@ -0,0 +1,1078 @@ + SUBROUTINE IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, + $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, + $ INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +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., 2000 (submitted). +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. +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 = 1, M + L + IREV = IREV - NOBR2 + ICOL = ICOL - LDRWRK + CALL DCOPY( NOBR2, DWORK(IREV), -1, DWORK(ICOL), -1 ) + 10 CONTINUE +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR2, M, U, LDU, DWORK(ICONN+NOBR2), + $ LDRWRK ) + CALL DLACPY( 'Full', NOBR2, L, Y, LDY, + $ DWORK(ICONN+LDRWRK*M+NOBR2), LDRWRK ) + END IF +C + IF ( M.GT.0 ) THEN +C +C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + +C ... + u_(i+NSM-1)*u_(j+NSM-1)', +C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, +C NSM = NSMP - 2s, and Guu0(i,j) is a zero matrix for +C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed +C till the current block for BATCH = 'I' or 'L'. The matrix +C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The +C submatrices of the first block-row, Guu(1,j), are needed only. +C +C Compute/update Guu(1,1). +C + IF( .NOT.FIRST .AND. CONNEC ) + $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR2, ONE, + $ DWORK(ICONN), LDRWRK, UPD, DWORK(IPG), NRG ) + CALL DSYRK( 'Upper', 'Transpose', M, NSM, ONE, U, LDU, UPD, + $ DWORK(IPG), NRG ) + CALL MA02ED( 'Upper', M, DWORK(IPG), NRG ) +C + JD = 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 20 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Guu(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, + $ U, LDU, U(J,1), LDU, UPD, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + 20 CONTINUE +C + ELSE +C + DO 30 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Guu(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR2, + $ ONE, DWORK(ICONN), LDRWRK, DWORK(ICONN+J-1), + $ LDRWRK, UPD, DWORK(IPG+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, + $ U, LDU, U(J,1), LDU, ONE, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + 30 CONTINUE +C + END IF +C +C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + +C ... + u_(i+NSM-1)*y_(j+NSM-1)', +C where u_i' is the i-th row of U, y_j' is the j-th row +C of Y, j = 1 : 2s, i = 1 : 2s, NSM = NSMP - 2s, and +C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it +C is the matrix Guy(i,j) computed till the current block for +C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The submatrices +C of the first block-row, Guy(1,j), as well as the transposes +C of the submatrices of the first block-column, i.e., Gyu(1,j), +C are needed only. +C + JD = MMNOBR + 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 40 J = 1, NOBR2 +C +C Compute/update Guy(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, + $ U, LDU, Y(J,1), LDY, UPD, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + JD = JD + L + 40 CONTINUE +C + ELSE +C + DO 50 J = 1, NOBR2 +C +C Compute/update Guy(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR2, + $ ONE, DWORK(ICONN), LDRWRK, + $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, + $ U, LDU, Y(J,1), LDY, ONE, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + JD = JD + L + 50 CONTINUE +C + END IF +C +C Now, the first M "positive" generators have been built. +C Transpose Guy(1,1) in the first block of the Y part of the +C "positive" generators. +C + DO 60 J = 1, L + CALL DCOPY( M, DWORK(IPG+(MMNOBR+J-1)*NRG), 1, + $ DWORK(IPY+J-1), NRG ) + 60 CONTINUE +C + JD = 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 70 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Gyu(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, + $ Y, LDY, U(J,1), LDU, UPD, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + 70 CONTINUE +C + ELSE +C + DO 80 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Gyu(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NOBR2, + $ ONE, DWORK(ICONN+LDRWRK*M), LDRWRK, + $ DWORK(ICONN+J-1), LDRWRK, UPD, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, + $ Y, LDY, U(J,1), LDU, ONE, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + 80 CONTINUE +C + END IF +C + END IF +C +C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + +C y_(i+NSM-1)*y_(i+NSM-1)', +C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, +C NSM = NSMP - 2s, and Gyy0(i,j) is a zero matrix for +C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till +C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, +C and Gyy(j,j) is symmetric. The submatrices of the first +C block-row, Gyy(1,j), are needed only. +C + JD = MMNOBR + 1 +C +C Compute/update Gyy(1,1). +C + IF( .NOT.FIRST .AND. CONNEC ) + $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR2, ONE, + $ DWORK(ICONN+LDRWRK*M), LDRWRK, UPD, + $ DWORK(IPY+MMNOBR*NRG), NRG ) + CALL DSYRK( 'Upper', 'Transpose', L, NSM, ONE, Y, LDY, UPD, + $ DWORK(IPY+MMNOBR*NRG), NRG ) + CALL MA02ED( 'Upper', L, DWORK(IPY+MMNOBR*NRG), NRG ) +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 90 J = 2, NOBR2 + JD = JD + L +C +C Compute/update Gyy(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, + $ LDY, Y(J,1), LDY, UPD, DWORK(IPY+(JD-1)*NRG), + $ NRG ) + 90 CONTINUE +C + ELSE +C + DO 100 J = 2, NOBR2 + JD = JD + L +C +C Compute/update Gyy(1,j) for sequential processing with +C connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR2, ONE, + $ DWORK(ICONN+LDRWRK*M), LDRWRK, + $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, + $ LDY, Y(J,1), LDY, ONE, DWORK(IPY+(JD-1)*NRG), + $ NRG ) + 100 CONTINUE +C + END IF +C + IF ( .NOT.LAST ) THEN + IF ( FIRST ) THEN +C +C For sequential processing, save the first 2*NOBR-1 rows of +C the first block of U and Y in the appropriate +C (M+L)*(2*NOBR-1) locations of DWORK starting at (1+M)*NRG. +C These will be used to construct the last negative generator. +C + JD = NRG + IF ( M.GT.0 ) THEN + CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) +C + DO 110 J = 1, NOBR21 + JD = JD + MNRG + CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) + 110 CONTINUE +C + JD = JD + MNRG + END IF + CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) +C + DO 120 J = 1, NOBR21 + JD = JD + LNRG + CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) + 120 CONTINUE +C + END IF +C + IF ( CONNEC ) THEN +C +C For sequential processing with connected data blocks, +C save the remaining ("connection") elements of U and Y +C in (M+L)*2*NOBR locations of DWORK starting at ICONN. +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR2, M, U(NS,1), LDU, + $ DWORK(ICONN), NOBR2 ) + CALL DLACPY( 'Full', NOBR2, L, Y(NS,1), LDY, + $ DWORK(ICONN+MMNOBR), NOBR2 ) + END IF +C +C Return to get new data. +C + ICYCLE = ICYCLE + 1 + IF ( ICYCLE.GT.MAXCYC ) + $ IWARN = 1 + RETURN + END IF +C + IF ( LAST ) THEN +C +C Try to compute the R factor. +C +C Scale the first M+L positive generators and set the first +C M+L negative generators. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+M+L. +C + JWORK = NRG*2*NR + 1 + CALL DCOPY( M, DWORK(IPG), NRG+1, DWORK(JWORK), 1 ) + CALL DCOPY( L, DWORK(IPY+MMNOBR*NRG), NRG+1, DWORK(JWORK+M), + $ 1 ) +C + DO 130 I = 1, M + L + IWORK(I) = IDAMAX( M+L, DWORK(JWORK), 1 ) + DWORK(JWORK+IWORK(I)-1) = ZERO + 130 CONTINUE +C + DO 150 I = 1, M + L + IMAX = IWORK(I) + IF ( IMAX.LE.M ) THEN + ICOL = IMAX + ELSE + ICOL = MMNOBR - M + IMAX + END IF + BETA = SQRT( ABS( DWORK(IPG+IMAX-1+(ICOL-1)*NRG) ) ) + IF ( BETA.EQ.ZERO ) THEN +C +C Error exit. +C + INFO = 1 + RETURN + END IF + CALL DSCAL( NR, ONE / BETA, DWORK(IPG+IMAX-1), NRG ) + CALL DCOPY( NR, DWORK(IPG+IMAX-1), NRG, DWORK(ING+IMAX-1), + $ NRG ) + DWORK(IPG+IMAX-1+(ICOL-1)*NRG) = BETA + DWORK(ING+IMAX-1+(ICOL-1)*NRG) = ZERO +C + DO 140 J = I + 1, M + L + DWORK(IPG+IWORK(J)-1+(ICOL-1)*NRG) = ZERO + 140 CONTINUE +C + 150 CONTINUE +C +C Compute the last two generators. +C + IF ( .NOT.FIRST ) THEN +C +C For sequential processing, move the stored last negative +C generator. +C + CALL DCOPY( NR, DWORK(NRG), NRG, DWORK(ING+NRG-1), NRG ) + END IF +C + JD = NRG + IF ( M.GT.0 ) THEN +C + DO 160 J = NS, NSMP + CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) + JD = JD + MNRG + 160 CONTINUE +C + END IF +C + DO 170 J = NS, NSMP + CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) + JD = JD + LNRG + 170 CONTINUE +C + IF ( FIRST ) THEN + IF ( M.GT.0 ) THEN + CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) +C + DO 180 J = 1, NOBR21 + JD = JD + MNRG + CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) + 180 CONTINUE +C + JD = JD + MNRG + END IF + CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) +C + DO 190 J = 1, NOBR21 + JD = JD + LNRG + CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) + 190 CONTINUE +C + END IF +C + ITAU = JWORK + IPGC = IPG + MMNOBR*NRG +C + IF ( M.GT.0 ) THEN +C +C Process the input part of the generators. +C + JWORK = ITAU + M +C +C Reduce the first M columns of the matrix G1 of positive +C generators to an upper triangular form. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*M; +C prefer (M+L)*4*NOBR*(M+L+1)+M+M*NB. +C + INGC = ING + CALL DGEQRF( NRG, M, DWORK(IPG), NRG, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR; +C prefer (M+L)*4*NOBR*(M+L+1)+M+ +C ((M+L)*2*NOBR-M)*NB. +C + CALL DORMQR( 'Left', 'Transpose', NRG, NR-M, M, DWORK(IPG), + $ NRG, DWORK(ITAU), DWORK(IPG+MNRG), NRG, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Annihilate, column by column, the first M columns of the +C matrix G2 of negative generators, using Householder +C transformations and modified hyperbolic plane rotations. +C In the DLARF calls, ITAU is a pointer to the workspace +C array. +C + DO 210 J = 1, M + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, NR-J, DWORK(INGC), 1, TAU, + $ DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPG+(J-1)*(NRG+1)), DWORK(INGC), CS, + $ SN, IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 200 I = J*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 200 CONTINUE +C + INGC = INGP + 210 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', M, NR, DWORK(IPG), NRG, R, LDR ) +C + DO 220 I = ( MMNOBR - M )*NRG, MNRG, -MNRG + CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, + $ DWORK(IPG+I), NRG ) + 220 CONTINUE +C + DO 230 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG + CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 230 CONTINUE +C + CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) +C +C Update the input part of generators using Schur algorithm. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*(M+L)-M. +C + JDS = MNRG + ICOL = M +C + DO 280 K = 2, NOBR2 + CALL MB04OD( 'Full', M, NR-ICOL-M, L+1, DWORK(IPG+JDS), + $ NRG, DWORK(IPY+JDS), NRG, + $ DWORK(IPG+JDS+MNRG), NRG, + $ DWORK(IPY+JDS+MNRG), NRG, DWORK(ITAU), + $ DWORK(JWORK) ) +C + DO 250 J = 1, M + ICJ = ICOL + J + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, NR-ICJ, DWORK(INGC), 1, TAU, + $ DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPG+J-1+(ICJ-1)*NRG), DWORK(INGC), + $ CS, SN, IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 240 I = ICJ*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 240 CONTINUE +C + INGC = INGP + 250 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', M, NR-ICOL, DWORK(IPG+JDS), NRG, + $ R(ICOL+1,ICOL+1), LDR ) + ICOL = ICOL + M +C + DO 260 I = ( MMNOBR - M )*NRG, ICOL*NRG, -MNRG + CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, + $ DWORK(IPG+I), NRG ) + 260 CONTINUE +C + DO 270 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG + CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 270 CONTINUE +C + CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) + JDS = JDS + MNRG + 280 CONTINUE +C + END IF +C +C Process the output part of the generators. +C + JWORK = ITAU + L +C +C Reduce the first L columns of the submatrix +C G1(1:M+L+1,2*M*NOBR+1:2*(M+L)*NOBR) to upper triangular form. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*L; +C prefer (M+L)*4*NOBR*(M+L+1)+L+L*NB. +C + INGC = ING + MMNOBR*NRG + CALL DGEQRF( NRG, L, DWORK(IPGC), NRG, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need (M+L)*4*NOBR*(M+L+1)+L*2*NOBR; +C prefer (M+L)*4*NOBR*(M+L+1)+L+(L*2*NOBR-L)*NB. +C + CALL DORMQR( 'Left', 'Transpose', NRG, LLNOBR-L, L, + $ DWORK(IPGC), NRG, DWORK(ITAU), DWORK(IPGC+LNRG), + $ NRG, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Annihilate, column by column, the first L columns of the +C output part of the matrix G2 of negative generators, using +C Householder transformations and modified hyperbolic rotations. +C + DO 300 J = 1, L + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, LLNOBR-J, DWORK(INGC), 1, TAU, + $ DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPGC+(J-1)*(NRG+1)), DWORK(INGC), CS, SN, + $ IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 290 I = ( J + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 290 CONTINUE +C + INGC = INGP + 300 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', L, LLNOBR, DWORK(IPGC), NRG, + $ R(MMNOBR+1,MMNOBR+1), LDR ) +C + DO 310 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG + CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 310 CONTINUE +C +C Update the output part of generators using the Schur algorithm. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*L-L. +C + JDS = LNRG + ICOL = L +C + DO 350 K = 2, NOBR2 + CALL MB04OD( 'Full', L, LLNOBR-ICOL-L, M+1, DWORK(IPGC+JDS), + $ NRG, DWORK(IPGC+L+JDS), NRG, + $ DWORK(IPGC+JDS+LNRG), NRG, + $ DWORK(IPGC+L+JDS+LNRG), NRG, DWORK(ITAU), + $ DWORK(JWORK) ) +C + DO 330 J = 1, L + ICJ = ICOL + J + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, LLNOBR-ICJ, DWORK(INGC), 1, + $ TAU, DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPGC+J-1+(ICJ-1)*NRG), DWORK(INGC), + $ CS, SN, IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 320 I = ( ICJ + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 320 CONTINUE +C + INGC = INGP + 330 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', L, LLNOBR-ICOL, DWORK(IPGC+JDS), NRG, + $ R(MMNOBR+ICOL+1,MMNOBR+ICOL+1), LDR ) +C + DO 340 I = ( NR - L )*NRG, ( MMNOBR + ICOL )*NRG, -LNRG + CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 340 CONTINUE +C + ICOL = ICOL + L + JDS = JDS + LNRG + 350 CONTINUE +C + IF ( MOESP .AND. M.GT.0 ) THEN +C +C For the MOESP algorithm, interchange the past and future +C input parts of the R factor, and compute the new R factor +C using a specialized QR factorization. A tailored fast +C QR factorization for the MOESP algorithm could be slightly +C more efficient. +C + DO 360 J = 1, MNOBR + CALL DSWAP( J, R(1,J), 1, R(1,MNOBR+J), 1 ) + CALL DCOPY( MNOBR, R(J+1,MNOBR+J), 1, R(J+1,J), 1 ) + CALL DCOPY( MMNOBR-J, DUM, 0, R(J+1,MNOBR+J), 1 ) + 360 CONTINUE +C +C Triangularize the first two block columns (using structure), +C and apply the transformation to the corresponding part of +C the remaining block columns. +C Workspace: need 2*(M+L)*NOBR. +C + ITAU = 1 + JWORK = ITAU + MMNOBR + CALL MB04ID( MMNOBR, MMNOBR, MNOBR-1, LLNOBR, R, LDR, + $ R(1,MMNOBR+1), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF + END IF +C + NSMPSM = 0 + ICYCLE = 1 +C +C Return optimal workspace in DWORK(1). +C + DWORK( 1 ) = MAXWRK + MAXWRK = 1 + RETURN +C +C *** Last line of IB01MY *** + END diff --git a/modules/cacsd/src/slicot/ib01my.lo b/modules/cacsd/src/slicot/ib01my.lo new file mode 100755 index 000000000..afcbca4b6 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01my.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01my.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01my.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01nd.f b/modules/cacsd/src/slicot/ib01nd.f new file mode 100755 index 000000000..04c83349c --- /dev/null +++ b/modules/cacsd/src/slicot/ib01nd.f @@ -0,0 +1,707 @@ + SUBROUTINE IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, TOL, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +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, 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. +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, 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 ) + 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 + CALL DCOPY( MNOBR, R(I+1,I), -1, R(NR2,I), -1 ) + 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. +C + ITAU2 = JWORK + JWORK = ITAU2 + MNOBR + SVLMAX = ZERO + CALL MB03OD( 'QR', MNOBR, MNOBR, R, LDR, IWORK, TOLL, + $ SVLMAX, DWORK(ITAU2), RANK, SVAL, + $ DWORK(JWORK), IERR ) +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 + CALL DCOPY( MNOBR, R(NR2,I), 1, R(I+1,I), 1 ) + 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. +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), IERR ) +C +C Workspace: need 2*(M+L)*NOBR + L*NOBR; +C prefer 2*(M+L)*NOBR + L*NOBR*NB. +C + CALL DORMQR( 'Left', 'Transpose', LMNOBR, LNOBR, LMNOBR, + $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( RANK1.LT.LMNOBR ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 5 + END IF +C +C Apply the orthogonal transformations, in backward order, to +C [r_2(1:rank(r_1),:)' 0]', to obtain P'. +C Workspace: need 2*(M+L)*NOBR + L*NOBR; +C prefer 2*(M+L)*NOBR + L*NOBR*NB. +C + CALL DLASET( 'Full', LMNOBR-RANK1, LNOBR, ZERO, ZERO, + $ R(RANK1+1,NR4), LDR ) + CALL DORMQR( 'Left', 'NoTranspose', LMNOBR, LNOBR, LMNOBR, + $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = ITAU3 +C + IF ( M.GT.0 ) THEN +C +C Restore the saved transpose matrix from R_31. +C + DO 60 I = NR2, LMNOBR + CALL DCOPY( MNOBR, R(MNOBR+I,1), LDR, R(I+1,MNOBR+I), + $ 1 ) + 60 CONTINUE +C + END IF +C + END IF +C +C Workspace: need M*NOBR + L*NOBR; +C prefer larger. +C + CALL MB04IY( 'Left', 'NoTranspose', LMNOBR, LNOBR, LNOBR, + $ LNOBR-1, R(NR2,NR3), LDR, DWORK(ITAU2), + $ R(NR2,NR4), LDR, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need M*NOBR + L*NOBR; +C prefer M*NOBR + L*NOBR*NB. +C + JWORK = ITAU2 + CALL DORMQR( 'Left', 'NoTranspose', MMNOBR, LNOBR, MNOBR, + $ R(1,NRSAVE), LDR, DWORK(ITAU), R(1,NR4), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Now, the matrix P' is available in R_14 : R_34. +C Triangularize the matrix P'. +C Workspace: need 2*L*NOBR; +C prefer L*NOBR + L*NOBR*NB. +C + JWORK = ITAU + LNOBR + CALL DGEQRF( LMMNOB, LNOBR, R(1,NR4), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Copy the triangular factor to its final position, R_22. +C + CALL DLACPY( 'Upper', LNOBR, LNOBR, R(1,NR4), LDR, R(NR2,NR2), + $ LDR ) +C +C Restore Y_f. +C + CALL MA02AD( 'Full', LNOBR, LMMNOB, R(NR4,1), LDR, R(1,NR4), + $ LDR ) + END IF +C +C Find the singular value decomposition of R_22. +C Workspace: need 5*L*NOBR. +C + CALL MB03UD( 'NoVectors', 'Vectors', LNOBR, R(NR2,NR2), LDR, + $ DUM, 1, SV, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C +C Transpose R(m*s+1:(m+L)*s,m*s+1:(m+L)*s) in-situ; its +C columns will then be the singular vectors needed subsequently. +C + DO 70 I = NR2+1, LMNOBR + CALL DSWAP( LMNOBR-I+1, R(I,I-1), 1, R(I-1,I), LDR ) + 70 CONTINUE +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C numbers, if METH = 'N'. +C + DWORK(1) = MAXWRK + IF ( N4SID ) THEN + DWORK(2) = RCOND1 + DWORK(3) = RCOND2 + END IF + RETURN +C +C *** Last line of IB01ND *** + END diff --git a/modules/cacsd/src/slicot/ib01nd.lo b/modules/cacsd/src/slicot/ib01nd.lo new file mode 100755 index 000000000..6dec45a8f --- /dev/null +++ b/modules/cacsd/src/slicot/ib01nd.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01nd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01nd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01od.f b/modules/cacsd/src/slicot/ib01od.f new file mode 100755 index 000000000..521e13803 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01od.f @@ -0,0 +1,198 @@ + SUBROUTINE IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARN, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To estimate the system order, based on the singular values of the +C relevant part of the triangular factor of the concatenated block +C Hankel matrices. +C +C ARGUMENTS +C +C Mode Parameters +C +C CTRL CHARACTER*1 +C Specifies whether or not the user's confirmation of the +C system order estimate is desired, as follows: +C = 'C': user's confirmation; +C = 'N': no confirmation. +C If CTRL = 'C', a reverse communication routine, IB01OY, +C is called, and, after inspecting the singular values and +C system order estimate, n, the user may accept n or set +C a new value. +C IB01OY is not called by the routine if CTRL = 'N'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the processed input and +C output block Hankel matrices. NOBR > 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C SV (input) DOUBLE PRECISION array, dimension ( L*NOBR ) +C The singular values of the relevant part of the triangular +C factor from the QR factorization of the concatenated block +C Hankel matrices. +C +C N (output) INTEGER +C The estimated order of the system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Absolute tolerance used for determining an estimate of +C the system order. If TOL >= 0, the estimate is +C indicated by the index of the last singular value greater +C than or equal to TOL. (Singular values less than TOL +C are considered as zero.) When TOL = 0, an internally +C computed default value, TOL = NOBR*EPS*SV(1), is used, +C where SV(1) is the maximal singular value, and EPS is +C the relative machine precision (see LAPACK Library routine +C DLAMCH). When TOL < 0, the estimate is indicated by the +C index of the singular value that has the largest +C logarithmic gap to its successor. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 3: all singular values were exactly zero, hence N = 0. +C (Both input and output were identically zero.) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The singular values are compared to the given, or default TOL, and +C the estimated order n is returned, possibly after user's +C confirmation. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C August 2000. +C +C KEYWORDS +C +C Identification methods, multivariable systems, singular value +C decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, N, NOBR + CHARACTER CTRL +C .. Array Arguments .. + DOUBLE PRECISION SV(*) +C .. Local Scalars .. + DOUBLE PRECISION GAP, RNRM, TOLL + INTEGER I, IERR, LNOBR + LOGICAL CONTRL +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL IB01OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, LOG10 +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + CONTRL = LSAME( CTRL, 'C' ) + LNOBR = L*NOBR + IWARN = 0 + INFO = 0 + IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( NOBR.LE.0 ) THEN + INFO = -2 + ELSE IF( L.LE.0 ) THEN + INFO = -3 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01OD', -INFO ) + RETURN + END IF +C +C Set TOL if necessay. +C + TOLL = TOL + IF ( TOLL.EQ.ZERO) + $ TOLL = DLAMCH( 'Precision' )*SV(1)*DBLE( NOBR ) +C +C Obtain the system order. +C + N = 0 + IF ( SV(1).NE.ZERO ) THEN + N = NOBR + IF ( TOLL.GE.ZERO) THEN +C +C Estimate n based on the tolerance TOLL. +C + DO 10 I = 1, NOBR - 1 + IF ( SV(I+1).LT.TOLL ) THEN + N = I + GO TO 30 + END IF + 10 CONTINUE + ELSE +C +C Estimate n based on the largest logarithmic gap between +C two consecutive singular values. +C + GAP = ZERO + DO 20 I = 1, NOBR - 1 + RNRM = SV(I+1) + IF ( RNRM.NE.ZERO ) THEN + RNRM = LOG10( SV(I) ) - LOG10( RNRM ) + IF ( RNRM.GT.GAP ) THEN + GAP = RNRM + N = I + END IF + ELSE + IF ( GAP.EQ.ZERO ) + $ N = I + GO TO 30 + END IF + 20 CONTINUE + END IF + END IF +C + 30 CONTINUE + IF ( N.EQ.0 ) THEN +C +C Return with N = 0 if all singular values are zero. +C + IWARN = 3 + RETURN + END IF +C + IF ( CONTRL ) THEN +C +C Ask confirmation of the system order. +C + CALL IB01OY( LNOBR, NOBR-1, N, SV, IERR ) + END IF + RETURN +C +C *** Last line of IB01OD *** + END diff --git a/modules/cacsd/src/slicot/ib01od.lo b/modules/cacsd/src/slicot/ib01od.lo new file mode 100755 index 000000000..eca1336b0 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01od.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01od.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01od.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01oy.f b/modules/cacsd/src/slicot/ib01oy.f new file mode 100755 index 000000000..23c8de3e9 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01oy.f @@ -0,0 +1,159 @@ + SUBROUTINE IB01OY( NS, NMAX, N, SV, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To ask for user's confirmation of the system order found by +C SLICOT Library routine IB01OD. This routine may be modified, +C but its interface must be preserved. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NS (input) INTEGER +C The number of singular values. NS > 0. +C +C NMAX (input) INTEGER +C The maximum value of the system order. 0 <= NMAX <= NS. +C +C N (input/output) INTEGER +C On entry, the estimate of the system order computed by +C IB01OD routine. 0 <= N <= NS. +C On exit, the user's estimate of the system order, which +C could be identical with the input value of N. +C Note that the output value of N should be less than +C or equal to NMAX. +C +C SV (input) DOUBLE PRECISION array, dimension ( NS ) +C The singular values, in descending order, used for +C determining the system order. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Identification, parameter estimation, singular values, structure +C identification. +C +C ********************************************************************* +C +C .. Parameters .. + INTEGER INTRMN, OUTRMN + PARAMETER ( INTRMN = 5, OUTRMN = 6 ) +C INTRMN is the unit number for the (terminal) input device. +C OUTRMN is the unit number for the (terminal) output device. +C .. +C .. Scalar Arguments .. + INTEGER INFO, N, NMAX, NS +C .. +C .. Array Arguments .. + DOUBLE PRECISION SV( * ) +C .. +C .. Local Scalars .. + LOGICAL YES + INTEGER I + CHARACTER ANS +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF( NS.LE.0 ) THEN + INFO = -1 + ELSE IF( NMAX.LT.0 .OR. NMAX.GT.NS ) THEN + INFO = -2 + ELSE IF( N.LT.0 .OR. N.GT.NS ) THEN + INFO = -3 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01OY', -INFO ) + RETURN + END IF +C + WRITE( OUTRMN, '(/'' Singular values (in descending order) used'', + $ '' to estimate the system order:'', // + $ (5D15.8) )' ) ( SV(I), I = 1, NS ) + WRITE( OUTRMN, '(/'' Estimated order of the system, n = '', I5 )' + $ ) N + WRITE( OUTRMN, '(/'' Do you want this value of n to be used'', + $ '' to determine the system matrices?'' )' ) +C + 10 CONTINUE + WRITE( OUTRMN, '(/'' Type "yes" or "no": '' )' ) + READ ( INTRMN, '( A )' ) ANS + YES = LSAME( ANS, 'Y' ) + IF( YES ) THEN + IF( N.LE.NMAX ) THEN +C +C The value of n is adequate and has been confirmed. +C + RETURN + ELSE +C +C The estimated value of n is not acceptable. +C + WRITE( OUTRMN, '(/'' n should be less than or equal'', + $ '' to '', I5 )' ) NMAX + WRITE( OUTRMN, '( '' (It may be useful to restart'', + $ '' with a larger tolerance.)'' )' ) + GO TO 20 + END IF +C + ELSE IF( LSAME( ANS, 'N' ) ) THEN + GO TO 20 + ELSE +C +C Wrong answer should be re-entered. +C + GO TO 10 + END IF +C +C Enter the desired value of n. +C + 20 CONTINUE + WRITE( OUTRMN,'(/'' Enter the desired value of n (n <= '', I5, + $ ''); n = '' )' ) NMAX + READ ( INTRMN, * ) N + IF ( N.LT.0 ) THEN +C +C The specified value of n is not acceptable. +C + WRITE( OUTRMN, '(/'' n should be larger than zero.'' )' ) + GO TO 20 + ELSE IF ( N.GT.NMAX ) THEN +C +C The specified value of n is not acceptable. +C + WRITE( OUTRMN, '(/'' n should be less than or equal to '', + $ I5 )' ) NMAX + GO TO 20 + END IF +C + RETURN +C +C *** Last line of IB01OY *** + END diff --git a/modules/cacsd/src/slicot/ib01oy.lo b/modules/cacsd/src/slicot/ib01oy.lo new file mode 100755 index 000000000..201398b86 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01oy.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01oy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01oy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01pd.f b/modules/cacsd/src/slicot/ib01pd.f new file mode 100755 index 000000000..2220b6b62 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01pd.f @@ -0,0 +1,1212 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 2000. +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 + max( 3*L*NOBR, 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), M*NOBR+2*N+L ), 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), +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. +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 IF( LDWORK.GE.1 ) THEN +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, 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, 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,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( TOLL, 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). +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), + $ IERR ) +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, TOLL, + $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), + $ IERR ) + CALL MB02QY( N, N, NPL, RANKM, R(NR2,NR2), LDR, IWORK, + $ R(NR2,NR4MN), LDR, DWORK(ITAU+MNOBR), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = ITAU + IF ( M.GT.0 .AND. WITHB ) + $ CALL DLACPY( 'Full', LNOBR, N, R(NR4,1), LDR, R(NR2,1), + $ LDR ) + END IF +C + IF ( WITHC ) THEN +C +C Obtain A and C, noting that block-permutations have been +C implicitly used. +C + CALL MA02AD( 'Full', N, N, R(NR2,NR4MN), LDR, A, LDA ) + CALL MA02AD( 'Full', N, L, R(NR2,NR4MN+N), LDR, C, LDC ) + ELSE +C +C Use the given A and C. +C + CALL MA02AD( 'Full', N, N, A, LDA, R(NR2,NR4MN), LDR ) + CALL MA02AD( 'Full', L, N, C, LDC, R(NR2,NR4MN+N), LDR ) + END IF +C + IF ( M.GT.0 .AND. WITHB ) THEN +C +C Obtain B and D. +C First, compute the transpose of the matrix K as +C N(1:m*s,:) - M(1:m*s,m*s+1:m*s+n)*[A' C'], in the first +C m*s rows of R(1,NR4MN). +C + CALL DGEMM ( 'NoTranspose', 'NoTranspose', MNOBR, NPL, N, + $ -ONE, R(1,NR2), LDR, R(NR2,NR4MN), LDR, ONE, + $ R(1,NR4MN), LDR ) +C +C Denote M = pinv(GaL) and construct +C +C [ [ A ] -1 ] [ R ] +C and L = [ [ ] R 0 ] Q', where Gam = Q * [ ]. +C [ [ C ] ] [ 0 ] +C +C Then, solve the least squares problem. +C + CALL DLACPY( 'Full', N, N, A, LDA, R(NR2,NR4), LDR ) + CALL DLACPY( 'Full', L, N, C, LDC, R(NR2+N,NR4), LDR ) + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', + $ NPL, N, ONE, R(NR2,1), LDR, R(NR2,NR4), LDR ) + CALL DLASET( 'Full', NPL, LNOBRN, ZERO, ZERO, R(NR2,NR4+N), + $ LDR ) +C +C Workspace: need 2*N+L; prefer N + (N+L)*NB. +C + CALL DORMQR( 'Right', 'Transpose', NPL, LNOBR, N, R(NR2,1), + $ LDR, DWORK, R(NR2,NR4), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Obtain the matrix K by transposition, and find B and D. +C Workspace: need NOBR*(M*(N+L))**2+M*NOBR*(N+L)+ +C max((N+L)**2,4*M*(N+L)+1); +C prefer larger. +C + CALL MA02AD( 'Full', MNOBR, NPL, R(1,NR4MN), LDR, + $ R(NR2,NR3), LDR ) + IX = MNOBR*NPL**2*M + 1 + JWORK = IX + MNOBR*NPL + CALL IB01PX( JOBPY, NOBR, N, M, L, R, LDR, O, LDO, + $ R(NR2,NR4), LDR, R(NR4PL,NR2), LDR, R(NR2,NR3), + $ LDR, DWORK, MNOBR*NPL, DWORK(IX), B, LDB, D, + $ LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, + $ IWARNL, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + IWARN = MAX( IWARN, IWARNL ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + RCOND4 = DWORK(JWORK+1) +C + END IF + END IF +C + 30 CONTINUE +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C numbers in the next locations. +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND1 + DWORK(3) = RCOND2 + DWORK(4) = RCOND3 + DWORK(5) = RCOND4 + RETURN +C +C *** Last line of IB01PD *** + END diff --git a/modules/cacsd/src/slicot/ib01pd.lo b/modules/cacsd/src/slicot/ib01pd.lo new file mode 100755 index 000000000..a0e28ebe3 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01pd.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01pd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01pd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01px.f b/modules/cacsd/src/slicot/ib01px.f new file mode 100755 index 000000000..db5dcea86 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01px.f @@ -0,0 +1,458 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 2000. +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 - +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 IF( LDWORK.GE.1 ) THEN +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MINWRK = MAX( NPL*NPL, 4*M*NPL + 1 ) +C + IF ( LDWORK.LT.MINWRK ) THEN + INFO = -26 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01PX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Construct the matrix [ Q_11 Q_12 ... Q_1,s-1 Q_1s ] in UL. +C + DO 20 J = 1, L +C + DO 10 I = 1, NPL + UL(I,J) = -UL(I,J) + 10 CONTINUE +C + UL(N+J,J) = ONE + UL(N+J,J) + 20 CONTINUE +C + DO 50 J = LP1, LNOBR +C + DO 30 I = 1, N + UL(I,J) = PGAL(I,J-L) - UL(I,J) + 30 CONTINUE +C + DO 40 I = NP1, NPL + UL(I,J) = -UL(I,J) + 40 CONTINUE +C + 50 CONTINUE +C +C Compute the coefficient matrix T using Kronecker products. +C Workspace: (N+L)*(N+L). +C In the same loop, vectorize K in X. +C + CALL DLASET( 'Full', MNOBR*NPL, M*NPL, ZERO, ZERO, R, LDR ) + CALL DLASET( 'Lower', MNOBR-1, MNOBR-1, ZERO, ZERO, UF(2,1), + $ LDUF ) + JWORK = NPL*L + 1 +C + DO 60 I = 1, NOBR + CALL DLACPY( 'Full', NPL, L, UL(1,(I-1)*L+1), LDUL, DWORK, + $ NPL ) + IF ( I.LT.NOBR ) THEN + CALL DGEMM ( 'NoTranspose', 'NoTranspose', NPL, N, + $ L*(NOBR-I), ONE, UL(1,I*L+1), LDUL, UN, LDUN, + $ ZERO, DWORK(JWORK), NPL ) + ELSE + CALL DLASET( 'Full', NPL, N, ZERO, ZERO, DWORK(JWORK), NPL ) + END IF + CALL MB01VD( 'NoTranspose', 'NoTranspose', MNOBR, M, NPL, + $ NPL, ONE, ONE, UF(1,(I-1)*M+1), LDUF, DWORK, + $ NPL, R, LDR, MKRON, NKRON, IERR ) + CALL DLACPY( 'Full', NPL, M, K(1,(I-1)*M+1), LDK, + $ X((I-1)*NKRON+1), NPL ) + 60 CONTINUE +C +C Compute the tolerance. +C + TOLL = TOL + IF( TOLL.LE.ZERO ) + $ TOLL = MKRON*NKRON*DLAMCH( 'Precision' ) +C +C Solve the least square problem T*X = vec(K). +C Workspace: need 4*M*(N+L)+1; +C prefer 3*M*(N+L)+(M*(N+L)+1)*NB. +C + DO 70 I = 1, NKRON + IWORK(I) = 0 + 70 CONTINUE +C + CALL DGELSY( MKRON, NKRON, 1, R, LDR, X, MKRON, IWORK, TOLL, RANK, + $ DWORK, LDWORK, IERR ) + MAXWRK = DWORK(1) +C +C Compute the reciprocal of the condition number of the triangular +C factor R of T. +C Workspace: need 3*M*(N+L). +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', NKRON, R, LDR, RCOND, + $ DWORK, IWORK, IERR ) +C + IF ( RANK.LT.NKRON ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 4 + END IF +C +C Construct the matrix D, if needed. +C + IF ( WITHD ) + $ CALL DLACPY( 'Full', L, M, X, NPL, D, LDD ) +C +C Construct the matrix B. +C + CALL DLACPY( 'Full', N, M, X(LP1), NPL, B, LDB ) +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C number in DWORK(2). +C + DWORK(1) = MAX( MINWRK, MAXWRK ) + DWORK(2) = RCOND +C + RETURN +C +C *** Last line of IB01PX *** + END diff --git a/modules/cacsd/src/slicot/ib01px.lo b/modules/cacsd/src/slicot/ib01px.lo new file mode 100755 index 000000000..abbe03581 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01px.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01px.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01px.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01py.f b/modules/cacsd/src/slicot/ib01py.f new file mode 100755 index 000000000..1e24dc20a --- /dev/null +++ b/modules/cacsd/src/slicot/ib01py.f @@ -0,0 +1,749 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 2000. +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, 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. +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 IF( LDWORK.GE.1 ) THEN +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, 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. +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), IERR ) +C +C Workspace: need L*NOBR+M; prefer L*NOBR+M*NB. +C + CALL DORMQR( 'Left', 'Transpose', LNOBR, M, LNOBR, R, LDR, + $ DWORK(ITAU), H, LDH, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) + IF ( RANK.LT.LNOBR ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 4 + END IF +C +C Workspace: need L*NOBR+max(L*NOBR,M); prefer larger. +C + CALL MB02QY( LNOBR, LNOBR, M, RANK, R, LDR, IWORK, H, LDH, + $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C +C Construct the matrix D, if needed. +C + IF ( WITHD ) + $ CALL DLACPY( 'Full', L, M, H(LDUN2+1,1), LDH, D, LDD ) +C +C Compute B by solving another linear system (possibly in +C a least squares sense). +C +C Make a block-permutation of the rows of the right-hand side, H, +C to construct the matrix +C +C [ H(L*(s-2)+1:L*(s-1),:); ... H(L+1:L*2,:); H(1:L),:) ] +C +C in H(1:L*s-L,1:n). +C + NOBRH = NOBR/2 + MOD( NOBR, 2 ) - 1 +C + DO 120 J = 1, M +C + DO 110 I = 1, NOBRH + CALL DSWAP( L, H(L*(I-1)+1,J), 1, H(L*(NOBR-I-1)+1,J), 1 ) + 110 CONTINUE +C + 120 CONTINUE +C +C Solve for B the matrix equation GaL*B = H(1:L*s-L,:), using +C the available QR factorization of GaL, if METH = 'M' and +C rank(GaL) = n, or the available pseudoinverse of GaL, otherwise. +C + IF ( MOESP .AND. RANKR1.EQ.N ) THEN +C +C The triangular factor r1 of GaL is considered to be of +C full rank. Compute Q1'*H in H and then solve for B, +C r1*B = H(1:n,:) in B, where Q1 is the orthogonal matrix +C in the QR factorization of GaL. +C Workspace: need M; prefer M*NB. +C + CALL DORMQR( 'Left', 'Transpose', LDUN2, M, N, R1, LDR1, + $ TAU1, H, LDH, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C +C Compute the solution in B. +C + CALL DLACPY( 'Full', N, M, H, LDH, B, LDB ) +C + CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, M, R1, LDR1, + $ B, LDB, IERR ) + IF ( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + ELSE +C +C Rank-deficient triangular factor r1. Use the available +C pseudoinverse of GaL for computing B from GaL*B = H. +C + CALL DGEMM ( 'NoTranspose', 'NoTranspose', N, M, LDUN2, ONE, + $ PGAL, LDPGAL, H, LDH, ZERO, B, LDB ) + END IF +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C number in DWORK(2). +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND +C + RETURN +C +C *** Last line of IB01PY *** + END diff --git a/modules/cacsd/src/slicot/ib01py.lo b/modules/cacsd/src/slicot/ib01py.lo new file mode 100755 index 000000000..f8a1b8f82 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01py.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01py.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01py.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01qd.f b/modules/cacsd/src/slicot/ib01qd.f new file mode 100755 index 000000000..a42b0caff --- /dev/null +++ b/modules/cacsd/src/slicot/ib01qd.f @@ -0,0 +1,1065 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To estimate the initial state and the system matrices B and D +C of a linear time-invariant (LTI) discrete-time system, given the +C matrix pair (A,C) and the input and output trajectories of the +C system. The model structure is : +C +C x(k+1) = Ax(k) + Bu(k), k >= 0, +C y(k) = Cx(k) + Du(k), +C +C where x(k) is the n-dimensional state vector (at time k), +C u(k) is the m-dimensional input vector, +C y(k) is the l-dimensional output vector, +C and A, B, C, and D are real matrices of appropriate dimensions. +C Matrix A is assumed to be in a real Schur form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX0 CHARACTER*1 +C Specifies whether or not the initial state should be +C computed, as follows: +C = 'X': compute the initial state x(0); +C = 'N': do not compute the initial state (x(0) is known +C to be zero). +C +C JOB CHARACTER*1 +C Specifies which matrices should be computed, as follows: +C = 'B': compute the matrix B only (D is known to be zero); +C = 'D': compute the matrices B and D. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). +C NSMP >= N*M + a + e, where +C a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'; +C e = 0, if JOBX0 = 'X' and JOB = 'B'; +C e = 1, if JOBX0 = 'N' and JOB = 'B'; +C e = M, if JOB = 'D'. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading L-by-N part of this array must contain the +C system output matrix C (corresponding to the real Schur +C form of A). +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= L. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,M) +C On entry, the leading NSMP-by-M part of this array must +C contain the t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C On exit, if JOB = 'D', the leading NSMP-by-M part of +C this array contains details of the QR factorization of +C the t-by-m matrix U, possibly computed sequentially +C (see METHOD). +C If JOB = 'B', this array is unchanged on exit. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,NSMP), if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= MAX(1,NSMP). +C +C X0 (output) DOUBLE PRECISION array, dimension (N) +C If JOBX0 = 'X', the estimated initial state of the +C system, x(0). +C If JOBX0 = 'N', x(0) is set to zero without any +C calculations. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If N > 0, M > 0, and INFO = 0, the leading N-by-M +C part of this array contains the system input matrix B +C in the coordinates corresponding to the real Schur form +C of A. +C If N = 0 or M = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if N > 0 and M > 0; +C LDB >= 1, if N = 0 or M = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C If M > 0, JOB = 'D', and INFO = 0, the leading +C L-by-M part of this array contains the system input-output +C matrix D. +C If M = 0 or JOB = 'B', this array is not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'D'; +C LDD >= 1, if M = 0 or JOB = 'B'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; a matrix whose estimated condition +C number is less than 1/TOL is considered to be of full +C rank. If the user sets TOL <= 0, then EPS is used +C instead, where EPS is the relative machine precision +C (see LAPACK Library routine DLAMCH). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK >= N*M + a, if JOB = 'B', +C LIWORK >= max( N*M + a, M ), if JOB = 'D', +C with a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; DWORK(2) contains the reciprocal condition +C number of the triangular factor of the QR factorization of +C the matrix W2 (see METHOD); if M > 0 and JOB = 'D', +C DWORK(3) contains the reciprocal condition number of the +C triangular factor of the QR factorization of U. +C On exit, if INFO = -23, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( LDW1, min( LDW2, LDW3 ) ), where +C LDW1 = 2, if M = 0 or JOB = 'B', +C LDW1 = 3, if M > 0 and JOB = 'D', +C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), +C LDW2 = LDWa, if M = 0 or JOB = 'B', +C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), +C if M > 0 and JOB = 'D', +C LDWb = (b + r)*(r + 1) + +C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), +C LDW3 = LDWb, if M = 0 or JOB = 'B', +C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), +C if M > 0 and JOB = 'D', +C r = N*M + a, +C a = 0, if JOBX0 = 'N', +C a = N, if JOBX0 = 'X'; +C b = 0, if JOB = 'B', +C b = L*M, if JOB = 'D'; +C c = 0, if JOBX0 = 'N', +C c = L*N, if JOBX0 = 'X'; +C d = 0, if JOBX0 = 'N', +C d = 2*N*N + N, if JOBX0 = 'X'; +C f = 2*r, if JOB = 'B' or M = 0, +C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; +C q = b + r*L. +C For good performance, LDWORK should be larger. +C If LDWORK >= LDW2 or +C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + +C max( d, f ), +C then standard QR factorizations of the matrices U and/or +C W2 (see METHOD) are used. +C Otherwise, the QR factorizations are computed sequentially +C by performing NCYCLE cycles, each cycle (except possibly +C the last one) processing s < t samples, where s is +C chosen from the equation +C LDWORK = s*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + +C max( d, f ). +C (s is at least N*M+a+e, the minimum value of NSMP.) +C The computational effort may increase and the accuracy may +C decrease with the decrease of s. Recommended value is +C LDWORK = LDW2, assuming a large enough cache size, to +C also accommodate A, C, U, and Y. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C An extension and refinement of the method in [1,2] is used. +C Specifically, denoting +C +C X = [ vec(D')' vec(B)' x0' ]', +C +C where vec(M) is the vector obtained by stacking the columns of +C the matrix M, then X is the least squares solution of the +C system S*X = vec(Y), with the matrix S = [ diag(U) W ], +C defined by +C +C ( U | | ... | | | ... | | ) +C ( U | 11 | ... | n1 | 12 | ... | nm | ) +C S = ( : | y | ... | y | y | ... | y | P*Gamma ), +C ( : | | ... | | | ... | | ) +C ( U | | ... | | | ... | | ) +C ij +C diag(U) having L block rows and columns. In this formula, y +C are the outputs of the system for zero initial state computed +C using the following model, for j = 1:m, and for i = 1:n, +C ij ij ij +C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, +C +C ij ij +C y (k) = Cx (k), +C +C where e_i is the i-th n-dimensional unit vector, Gamma is +C given by +C +C ( C ) +C ( C*A ) +C Gamma = ( C*A^2 ), +C ( : ) +C ( C*A^(t-1) ) +C +C and P is a permutation matrix that groups together the rows of +C Gamma depending on the same row of C, namely +C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. +C The first block column, diag(U), is not explicitly constructed, +C but its structure is exploited. The last block column is evaluated +C using powers of A with exponents 2^k. No interchanges are applied. +C A special QR decomposition of the matrix S is computed. Let +C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where +C r is M-by-M. Then, diag(q') is applied to W and vec(Y). +C The block-rows of S and vec(Y) are implicitly permuted so that +C matrix S becomes +C +C ( diag(r) W1 ) +C ( 0 W2 ), +C +C where W1 has L*M rows. Then, the QR decomposition of W2 is +C computed (sequentially, if M > 0) and used to obtain B and x0. +C The intermediate results and the QR decomposition of U are +C needed to find D. If a triangular factor is too ill conditioned, +C then singular value decomposition (SVD) is employed. SVD is not +C generally needed if the input sequence is sufficiently +C persistently exciting and NSMP is large enough. +C If the matrix W cannot be stored in the workspace (i.e., +C LDWORK < LDW2), the QR decompositions of W2 and U are +C computed sequentially. +C +C REFERENCES +C +C [1] Verhaegen M., and Varga, A. +C Some Experience with the MOESP Class of Subspace Model +C Identification Methods in Identifying the BO105 Helicopter. +C Report TR R165-94, DLR Oberpfaffenhofen, 1994. +C +C [2] Sima, V., and Varga, A. +C RASP-IDENT : Subspace Model Identification Programs. +C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., +C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C FURTHER COMMENTS +C +C The algorithm for computing the system matrices B and D is +C less efficient than the MOESP or N4SID algorithms implemented in +C SLICOT Library routine IB01PD, because a large least squares +C problem has to be solved, but the accuracy is better, as the +C computed matrices B and D are fitted to the input and output +C trajectories. However, if matrix A is unstable, the computed +C matrices B and D could be inaccurate. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, + $ LDWORK, LDY, M, N, NSMP + CHARACTER JOB, JOBX0 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION RCOND, RCONDU, TOLL + INTEGER I, I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, + $ IG, IGAM, IGS, INI, INIH, INIR, INIS, INY, + $ INYGAM, IQ, IREM, IRHS, ISIZE, ISV, ITAU, + $ ITAUU, IUPNT, IX, IXINIT, IXSAVE, IY, IYPNT, J, + $ JWORK, K, LDDW, LDR, LDW2, LDW3, LM, LN, LNOB, + $ MAXWRK, MINSMP, MINWLS, MINWRK, N2M, NCOL, + $ NCP1, NCYCLE, NM, NN, NOBS, NROW, NSMPL, RANK + LOGICAL FIRST, NCYC, POWER2, WITHB, WITHD, WITHX0 +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, + $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSM, + $ MA02AD, MB01TD, MB02UD, MB04OD, MB04OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD +C .. Executable Statements .. +C +C Check the input parameters. +C + WITHD = LSAME( JOB, 'D' ) + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + WITHX0 = LSAME( JOBX0, 'X' ) +C + IWARN = 0 + INFO = 0 + LM = L*M + LN = L*N + NN = N*N + NM = N*M + N2M = N*NM + NCOL = NM + IF( WITHX0 ) + $ NCOL = NCOL + N + MINSMP = NCOL + IF( WITHD ) THEN + MINSMP = MINSMP + M + IQ = MINSMP + ELSE IF ( .NOT.WITHX0 ) THEN + IQ = MINSMP + MINSMP = MINSMP + 1 + ELSE + IQ = MINSMP + END IF +C + IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.WITHB ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( L.LE.0 ) THEN + INFO = -5 + ELSE IF( NSMP.LT.MINSMP ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.L ) THEN + INFO = -10 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -12 + ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) + $ THEN + INFO = -17 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) + $ THEN + INFO = -19 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -20 + END IF +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + NSMPL = NSMP*L + IQ = IQ*L + NCP1 = NCOL + 1 + ISIZE = NSMPL*NCP1 + IF ( N.GT.0 .AND. WITHX0 ) THEN + IC = 2*NN + N + ELSE + IC = 0 + END IF + MINWLS = NCOL*NCP1 + IF ( WITHD ) + $ MINWLS = MINWLS + LM*NCP1 + IF ( M.GT.0 .AND. WITHD ) THEN + IA = M + MAX( 2*NCOL, M ) + ELSE + IA = 2*NCOL + END IF + ITAU = N2M + MAX( IC, IA ) + IF ( WITHX0 ) + $ ITAU = ITAU + LN + LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) + LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) + IF ( M.GT.0 .AND. WITHD ) THEN + LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) + LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) + END IF + MINWRK = MIN( LDW2, LDW3 ) + MINWRK = MAX( MINWRK, 2 ) + IF ( M.GT.0 .AND. WITHD ) + $ MINWRK = MAX( MINWRK, 3 ) + IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN + IF ( M.GT.0 .AND. WITHD ) THEN + MAXWRK = ISIZE + N + M + + $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, M, -1, -1 ), + $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMP-M, + $ NCOL, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, ISIZE + N + M + + $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', NSMP, + $ NCP1, M, -1 ), + $ NCOL + ILAENV( 1, 'DORMQR', 'LT', + $ NSMP-M, 1, NCOL, -1 ) ) ) + ELSE + MAXWRK = ISIZE + N + NCOL + + $ MAX( NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMPL, NCOL, + $ -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT',NSMPL, 1, NCOL, + $ -1 ) ) + END IF + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF +C + IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN + INFO = -23 + DWORK(1) = MINWRK + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M ).EQ.0 ) THEN + DWORK(2) = ONE + IF ( M.GT.0 .AND. WITHD ) THEN + DWORK(1) = THREE + DWORK(3) = ONE + ELSE + DWORK(1) = TWO + END IF + RETURN + END IF +C +C Set up the least squares problem, either directly, if enough +C workspace, or sequentially, otherwise. +C + IYPNT = 1 + IUPNT = 1 + LDDW = ( LDWORK - MINWLS - ITAU )/NCP1 + NOBS = MIN( NSMP, LDDW/L ) +C + IF ( LDWORK.GE.LDW2 .OR. NSMP.LE.NOBS ) THEN +C +C Enough workspace for solving the problem directly. +C + NCYCLE = 1 + NOBS = NSMP + LDDW = MAX( 1, NSMPL ) + IF ( WITHD ) THEN + INIR = M + 1 + ELSE + INIR = 1 + END IF + INY = 1 + INIS = 1 + ELSE +C +C NCYCLE > 1 cycles are needed for solving the problem +C sequentially, taking NOBS samples in each cycle (or the +C remaining samples in the last cycle). +C + LNOB = L*NOBS + LDDW = MAX( 1, LNOB ) + NCYCLE = NSMP/NOBS + IF ( MOD( NSMP, NOBS ).NE.0 ) + $ NCYCLE = NCYCLE + 1 + INIR = 1 + INIH = INIR + NCOL*NCOL + INIS = INIH + NCOL + IF ( WITHD ) THEN + INY = INIS + LM*NCP1 + ELSE + INY = INIS + END IF + END IF +C + NCYC = NCYCLE.GT.1 + INYGAM = INY + LDDW*NM + IRHS = INY + LDDW*NCOL + IXINIT = IRHS + LDDW + IF( NCYC ) THEN + IC = IXINIT + N2M + IF ( WITHX0 ) THEN + IA = IC + LN + ELSE + IA = IC + END IF + LDR = MAX( 1, NCOL ) + IE = INY + ELSE + IF ( WITHD ) THEN + INIH = IRHS + M + ELSE + INIH = IRHS + END IF + IA = IXINIT + N + LDR = LDDW + IE = IXINIT + END IF + IF ( N.GT.0 .AND. WITHX0 ) + $ IAS = IA + NN +C + ITAUU = IA + IF ( WITHD ) THEN + ITAU = ITAUU + M + ELSE + ITAU = ITAUU + END IF + DUM(1) = ZERO +C + DO 190 ICYCLE = 1, NCYCLE + FIRST = ICYCLE.EQ.1 + IF ( .NOT.FIRST ) THEN + IF ( ICYCLE.EQ.NCYCLE ) THEN + NOBS = NSMP - ( NCYCLE - 1 )*NOBS + LNOB = L*NOBS + END IF + END IF +C + IY = INY + IXSAVE = IXINIT +C +C Compute the M*N output trajectories for zero initial state +C or for the saved final state value of the previous cycle. +C This can be performed in parallel. +C Workspace: need s*L*(r + 1) + b + w, +C where r = M*N + a, s = NOBS, +C a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'; +C b = N, if NCYCLE = 1; +C b = N*N*M, if NCYCLE > 1; +C w = 0, if NCYCLE = 1; +C w = r*(r+1), if NCYCLE > 1, JOB = 'B'; +C w = (M*L+r)*(r+1), if NCYCLE > 1, JOB = 'D'. +C + DO 40 J = 1, M + DO 30 I = 1, N +C ij +C Compute the y trajectory and put the vectorized form +C of it in an appropriate column of DWORK. To gain in +C efficiency, a specialization of SLICOT Library routine +C TF01ND is used. +C + IF ( FIRST ) + $ CALL DCOPY( N, DUM, 0, DWORK(IXSAVE), 1 ) + CALL DCOPY( N, DWORK(IXSAVE), 1, X0, 1 ) + INI = IY +C + DO 20 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, ONE, C, LDC, X0, 1, + $ ZERO, DWORK(IY), NOBS ) + IY = IY + 1 + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 10 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXSAVE+IX-2) + 10 CONTINUE +C + X0(I) = X0(I) + U(IUPNT+K-1,J) + CALL DCOPY( N, X0, 1, DWORK(IXSAVE), 1 ) + 20 CONTINUE +C + IF ( NCYC ) + $ IXSAVE = IXSAVE + N + IY = INI + LDDW + 30 CONTINUE +C + 40 CONTINUE +C + IF ( N.GT.0 .AND. WITHX0 ) THEN +C +C Compute the permuted extended observability matrix Gamma +C ij +C in the following N columns of DWORK (after the y +C trajectories). Gamma is directly constructed in the +C required row structure. +C Workspace: need s*L*(r + 1) + 2*N*N + N + b + c + w, +C where c = 0, if NCYCLE = 1; +C c = L*N, if NCYCLE > 1. +C + JWORK = IAS + NN + IG = INYGAM + IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) + IREM = NOBS - 2**IEXPON + POWER2 = IREM.EQ.0 + IF ( .NOT.POWER2 ) + $ IEXPON = IEXPON + 1 +C + IF ( FIRST ) THEN +C + DO 50 I = 1, N + CALL DCOPY( L, C(1,I), 1, DWORK(IG), NOBS ) + IG = IG + LDDW + 50 CONTINUE +C + ELSE +C + DO 60 I = IC, IC + LN - 1, L + CALL DCOPY( L, DWORK(I), 1, DWORK(IG), NOBS ) + IG = IG + LDDW + 60 CONTINUE +C + END IF +C p +C Use powers of the matrix A: A , p = 2**(J-1). +C + CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) + IF( N.GT.1 ) + $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) + I2 = 1 + NROW = 0 +C + DO 90 J = 1, IEXPON + IGAM = INYGAM + IF ( J.LT.IEXPON .OR. POWER2 ) THEN + NROW = I2 + ELSE + NROW = IREM + END IF +C + DO 80 I = 1, L + CALL DLACPY( 'Full', NROW, N, DWORK(IGAM), LDDW, + $ DWORK(IGAM+I2), LDDW ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', + $ 'Non Unit', NROW, N, ONE, DWORK(IA), N, + $ DWORK(IGAM+I2), LDDW ) + IG = IGAM +C p +C Compute the contribution of the subdiagonal of A +C to the product. +C + DO 70 IX = 1, N - 1 + CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), + $ DWORK(IG+LDDW), 1, DWORK(IG+I2), 1 ) + IG = IG + LDDW + 70 CONTINUE +C + IGAM = IGAM + NOBS + 80 CONTINUE +C + IF ( J.LT.IEXPON ) THEN + CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), + $ N ) + IF( N.GT.1 ) + $ CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), + $ N+1 ) + CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, + $ DWORK(JWORK), IERR ) + I2 = I2*2 + END IF + 90 CONTINUE +C + IF ( NCYC .AND. ICYCLE.LT.NCYCLE ) THEN + IG = INYGAM + I2 + NROW - 1 + IGS = IG +C + DO 100 I = IC, IC + LN - 1, L + CALL DCOPY( L, DWORK(IG), NOBS, DWORK(I), 1 ) + IG = IG + LDDW + 100 CONTINUE +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', + $ L, N, ONE, A, LDA, DWORK(IC), L ) + IG = IGS +C +C Compute the contribution of the subdiagonal of A to the +C product. +C + DO 110 IX = 1, N - 1 + CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), NOBS, + $ DWORK(IC+(IX-1)*L), 1 ) + IG = IG + LDDW + 110 CONTINUE +C + END IF + END IF +C +C Setup (part of) the right hand side of the least squares +C problem. +C + IY = IRHS +C + DO 120 K = 1, L + CALL DCOPY( NOBS, Y(IYPNT,K), 1, DWORK(IY), 1 ) + IY = IY + NOBS + 120 CONTINUE +C +C Compress the data using a special QR factorization. +C Workspace: need v + y, +C where v = s*L*(r + 1) + b + c + w + x, +C x = M, y = max( 2*r, M ), +C if JOB = 'D' and M > 0, +C x = 0, y = 2*r, if JOB = 'B' or M = 0. +C + IF ( M.GT.0 .AND. WITHD ) THEN +C +C Case 1: D is requested. +C + JWORK = ITAU + IF ( FIRST ) THEN + INI = INY + M +C +C Compress the first or single segment of U, U1 = Q1*R1. +C Workspace: need v + M; +C prefer v + M*NB. +C + CALL DGEQRF( NOBS, M, U, LDU, DWORK(ITAUU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C ij +C Apply diag(Q1') to the matrix [ y Gamma Y ]. +C Workspace: need v + r + 1, +C prefer v + (r + 1)*NB. +C + DO 130 K = 1, L + CALL DORMQR( 'Left', 'Transpose', NOBS, NCP1, M, U, + $ LDU, DWORK(ITAUU), DWORK(INY+(K-1)*NOBS), + $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) + 130 CONTINUE +C + IF ( NCOL.GT.0 ) THEN +C +C Compress the first part of the first data segment of +C ij +C [ y Gamma ]. +C Workspace: need v + 2*r, +C prefer v + r + r*NB. +C + JWORK = ITAU + NCOL + CALL DGEQRF( NOBS-M, NCOL, DWORK(INI), LDDW, + $ DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Apply the transformation to the corresponding right +C hand side part. +C Workspace: need v + r + 1, +C prefer v + r + NB. +C + CALL DORMQR( 'Left', 'Transpose', NOBS-M, 1, NCOL, + $ DWORK(INI), LDDW, DWORK(ITAU), + $ DWORK(IRHS+M), LDDW, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Compress the remaining parts of the first data segment +C ij +C of [ y Gamma ]. +C Workspace: need v + r - 1. +C + DO 140 K = 2, L + CALL MB04OD( 'Full', NCOL, 1, NOBS-M, DWORK(INI), + $ LDDW, DWORK(INI+(K-1)*NOBS), LDDW, + $ DWORK(IRHS+M), LDDW, + $ DWORK(IRHS+M+(K-1)*NOBS), LDDW, + $ DWORK(ITAU), DWORK(JWORK) ) + 140 CONTINUE +C + END IF +C + IF ( NCYC ) THEN +C ij +C Save the triangular factor of [ y Gamma ], the +C corresponding right hand side, and the first M rows +C in each NOBS group of rows. +C Workspace: need v. +C + CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INI), LDDW, + $ DWORK(INIR), LDR ) +C + DO 150 K = 1, L + CALL DLACPY( 'Full', M, NCP1, + $ DWORK(INY +(K-1)*NOBS), LDDW, + $ DWORK(INIS+(K-1)*M), LM ) + 150 CONTINUE +C + END IF + ELSE +C +C Compress the current data segment of U, Ui = Qi*Ri, +C i = ICYCLE. +C Workspace: need v + r + 1. +C + CALL MB04OD( 'Full', M, NCP1, NOBS, U, LDU, U(IUPNT,1), + $ LDU, DWORK(INIS), LM, DWORK(INY), LDDW, + $ DWORK(ITAUU), DWORK(JWORK) ) +C +C Apply diag(Qi') to the appropriate part of the matrix +C ij +C [ y Gamma Y ]. +C Workspace: need v + r + 1. +C + DO 170 K = 2, L +C + DO 160 IX = 1, M + CALL MB04OY( NOBS, NCP1, U(IUPNT,IX), + $ DWORK(ITAUU+IX-1), + $ DWORK(INIS+(K-1)*M+IX-1), LM, + $ DWORK(INY+(K-1)*NOBS), LDDW, + $ DWORK(JWORK) ) + 160 CONTINUE +C + 170 CONTINUE +C + IF ( NCOL.GT.0 ) THEN +C + JWORK = ITAU + NCOL +C +C Compress the current (but not the first) data segment +C ij +C of [ y Gamma ]. +C Workspace: need v + r - 1. +C + DO 180 K = 1, L + CALL MB04OD( 'Full', NCOL, 1, NOBS, DWORK(INIR), + $ LDR, DWORK(INY+(K-1)*NOBS), LDDW, + $ DWORK(INIH), LDR, + $ DWORK(IRHS+(K-1)*NOBS), LDDW, + $ DWORK(ITAU), DWORK(JWORK) ) + 180 CONTINUE +C + END IF + END IF +C + ELSE IF ( NCOL.GT.0 ) THEN +C +C Case 2: D is known to be zero. +C + JWORK = ITAU + NCOL + IF ( FIRST ) THEN +C +C Compress the first or single data segment of +C ij +C [ y Gamma ]. +C Workspace: need v + 2*r, +C prefer v + r + r*NB. +C + CALL DGEQRF( LDDW, NCOL, DWORK(INY), LDDW, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Apply the transformation to the right hand side. +C Workspace: need v + r + 1, +C prefer v + r + NB. +C + CALL DORMQR( 'Left', 'Transpose', LDDW, 1, NCOL, + $ DWORK(INY), LDDW, DWORK(ITAU), DWORK(IRHS), + $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( NCYC ) THEN +C ij +C Save the triangular factor of [ y Gamma ] and the +C corresponding right hand side. +C Workspace: need v. +C + CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INY), LDDW, + $ DWORK(INIR), LDR ) + END IF + ELSE +C +C Compress the current (but not the first) data segment. +C Workspace: need v + r - 1. +C + CALL MB04OD( 'Full', NCOL, 1, LNOB, DWORK(INIR), LDR, + $ DWORK(INY), LDDW, DWORK(INIH), LDR, + $ DWORK(IRHS), LDDW, DWORK(ITAU), + $ DWORK(JWORK) ) + END IF + END IF +C + IUPNT = IUPNT + NOBS + IYPNT = IYPNT + NOBS + 190 CONTINUE +C +C Estimate the reciprocal condition number of the triangular factor +C of the QR decomposition. +C Workspace: need u + 3*r, where +C u = t*L*(r + 1), if NCYCLE = 1; +C u = w, if NCYCLE > 1. +C + CALL DTRCON( '1-norm', 'Upper', 'No Transpose', NCOL, DWORK(INIR), + $ LDR, RCOND, DWORK(IE), IWORK, IERR ) +C + TOLL = TOL + IF ( TOLL.LE.ZERO ) + $ TOLL = DLAMCH( 'Precision' ) + IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN + IWARN = 4 +C +C The least squares problem is ill-conditioned. +C Use SVD to solve it. +C Workspace: need u + 6*r; +C prefer larger. +C + IF ( NCOL.GT.1 ) + $ CALL DLASET( 'Lower', NCOL-1, NCOL-1, ZERO, ZERO, + $ DWORK(INIR+1), LDR ) + ISV = IE + JWORK = ISV + NCOL + CALL DGELSS( NCOL, NCOL, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, + $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + IF ( IERR.GT.0 ) THEN +C +C Return if SVD algorithm did not converge. +C + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) + ELSE +C +C Find the least squares solution using QR decomposition only. +C + CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', NCOL, + $ 1, ONE, DWORK(INIR), LDR, DWORK(INIH), LDR ) + END IF +C +C Setup the estimated n-by-m input matrix B, and the estimated +C initial state of the system x0. +C + CALL DLACPY( 'Full', N, M, DWORK(INIH), N, B, LDB ) +C + IF ( N.GT.0 .AND. WITHX0 ) THEN + CALL DCOPY( N, DWORK(INIH+NM), 1, X0, 1 ) + ELSE + CALL DCOPY( N, DUM, 0, X0, 1 ) + END IF +C + IF ( M.GT.0 .AND. WITHD ) THEN +C +C Compute the estimated l-by-m input/output matrix D. +C + IF ( NCYC ) THEN + IRHS = INIS + LM*NCOL + CALL DGEMV( 'No Transpose', LM, NCOL, -ONE, DWORK(INIS), + $ LM, DWORK(INIH), 1, ONE, DWORK(IRHS), 1 ) + ELSE +C + DO 200 K = 1, L + CALL DGEMV( 'No Transpose', M, NCOL, -ONE, + $ DWORK(INIS+(K-1)*NOBS), LDDW, DWORK(INIH), 1, + $ ONE, DWORK(IRHS+(K-1)*NOBS), 1 ) + 200 CONTINUE +C + DO 210 K = 2, L + CALL DCOPY( M, DWORK(IRHS+(K-1)*NOBS), 1, + $ DWORK(IRHS+(K-1)*M), 1 ) + 210 CONTINUE +C + END IF +C +C Estimate the reciprocal condition number of the triangular +C factor of the QR decomposition of the matrix U. +C Workspace: need u + 3*M. +C + CALL DTRCON( '1-norm', 'Upper', 'No Transpose', M, U, LDU, + $ RCONDU, DWORK(IE), IWORK, IERR ) + IF ( RCONDU.LE.TOLL**( TWO/THREE ) ) THEN + IWARN = 4 +C +C The least squares problem is ill-conditioned. +C Use SVD to solve it. (QR decomposition of U is preserved.) +C Workspace: need u + 2*M*M + 6*M; +C prefer larger. +C + IQ = IE + M*M + ISV = IQ + M*M + JWORK = ISV + M + CALL DLACPY( 'Upper', M, M, U, LDU, DWORK(IE), M ) + CALL MB02UD( 'Not Factored', 'Left', 'No Transpose', + $ 'No Pinv', M, L, ONE, TOLL, RANK, DWORK(IE), + $ M, DWORK(IQ), M, DWORK(ISV), DWORK(IRHS), M, + $ DUM, 1, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( IERR.GT.0 ) THEN +C +C Return if SVD algorithm did not converge. +C + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) + ELSE + CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', M, + $ L, ONE, U, LDU, DWORK(IRHS), M ) + END IF + CALL MA02AD( 'Full', M, L, DWORK(IRHS), M, D, LDD ) +C + END IF +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND + IF ( M.GT.0 .AND. WITHD ) + $ DWORK(3) = RCONDU +C + RETURN +C +C *** End of IB01QD *** + END diff --git a/modules/cacsd/src/slicot/ib01qd.lo b/modules/cacsd/src/slicot/ib01qd.lo new file mode 100755 index 000000000..434bb7dd5 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01qd.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01qd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01qd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ib01rd.f b/modules/cacsd/src/slicot/ib01rd.f new file mode 100755 index 000000000..4e70e8fe9 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01rd.f @@ -0,0 +1,745 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 2000. +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 - +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 ) + CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) + I2 = L + NROW = 0 +C + DO 20 J = 1, IEXPON + IG = INIGAM + IF ( J.LT.IEXPON .OR. POWER2 ) THEN + NROW = I2 + ELSE + NROW = IREM + END IF +C + CALL DLACPY( 'Full', NROW, N, DWORK(IG), LDDW, DWORK(IG+I2), + $ LDDW ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', + $ NROW, N, ONE, DWORK(IA), N, DWORK(IG+I2), + $ LDDW ) +C p +C Compute the contribution of the subdiagonal of A to the +C product. +C + DO 10 IX = 1, N - 1 + CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), DWORK(IG+LDDW), + $ 1, DWORK(IG+I2), 1 ) + IG = IG + LDDW + 10 CONTINUE +C + IF ( J.LT.IEXPON ) THEN + CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), N ) + CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), N+1 ) + CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, + $ DWORK(JWORK), IERR ) + I2 = I2*2 + END IF + 20 CONTINUE +C + IF ( NCYC ) THEN + IG = INIGAM + I2 + NROW - L + CALL DLACPY( 'Full', L, N, DWORK(IG), LDDW, DWORK(IC), L ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', L, + $ N, ONE, A, LDA, DWORK(IC), L ) +C +C Compute the contribution of the subdiagonal of A to the +C product. +C + DO 30 IX = 1, N - 1 + CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), 1, + $ DWORK(IC+(IX-1)*L), 1 ) + IG = IG + LDDW + 30 CONTINUE +C + END IF +C +C Setup (part of) the right hand side of the least squares +C problem starting from DWORK(IRHS); use the estimated output +C trajectory for zero initial state, or for the saved final state +C value of the previous cycle. +C A specialization of SLICOT Library routine TF01ND is used. +C For large input sets (NSMP*M >= IBLOCK), chunks of U are +C transposed, to reduce the number of row-wise passes. +C Workspace: need s*L*(N + 1) + N + w; +C prefer as above, with s = t, w = 0. +C + IF ( FIRST ) + $ CALL DCOPY( N, DUM, 0, DWORK(IXINIT), 1 ) + CALL DCOPY( N, DWORK(IXINIT), 1, X0, 1 ) + IY = IRHS +C + DO 40 J = 1, L + CALL DCOPY( NOBS, Y(IYPNT,J), 1, DWORK(IY), L ) + IY = IY + 1 + 40 CONTINUE +C + IY = IRHS + IU = IUPNT + IF ( M.GT.0 ) THEN + IF ( WITHD ) THEN +C + IF ( BLOCK ) THEN + SWITCH = .TRUE. + NROW = NRBL +C + DO 60 K = 1, NOBS + IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN + IUT = IUTRAN + IF ( K.GT.INIT ) THEN + NROW = NOBS - INIT + SWITCH = .FALSE. + END IF + CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, + $ DWORK(IUT), M ) + IU = IU + NROW + END IF + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, + $ DWORK(IUT), 1, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 50 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 50 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ DWORK(IUT), 1, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IUT = IUT + M + 60 CONTINUE +C + ELSE +C + DO 80 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, + $ U(IU,1), LDU, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 70 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 70 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IU,1), LDU, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IU = IU + 1 + 80 CONTINUE +C + END IF +C + ELSE +C + IF ( BLOCK ) THEN + SWITCH = .TRUE. + NROW = NRBL +C + DO 100 K = 1, NOBS + IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN + IUT = IUTRAN + IF ( K.GT.INIT ) THEN + NROW = NOBS - INIT + SWITCH = .FALSE. + END IF + CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, + $ DWORK(IUT), M ) + IU = IU + NROW + END IF + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 90 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 90 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ DWORK(IUT), 1, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IUT = IUT + M + 100 CONTINUE +C + ELSE +C + DO 120 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 110 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 110 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IU,1), LDU, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IU = IU + 1 + 120 CONTINUE +C + END IF +C + END IF +C + ELSE +C + DO 140 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, 1, + $ ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, A, + $ LDA, X0, 1 ) +C + DO 130 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 130 CONTINUE +C + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + 140 CONTINUE +C + END IF +C +C Compress the data using (sequential) QR factorization. +C Workspace: need v + 2*N; +C where v = s*L*(N + 1) + N + a + w. +C + JWORK = ITAU + N + IF ( FIRST ) THEN +C +C Compress the first data segment of Gamma. +C Workspace: need v + 2*N, +C prefer v + N + N*NB. +C + CALL DGEQRF( LDDW, N, DWORK(INIGAM), LDDW, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Apply the transformation to the right hand side part. +C Workspace: need v + N + 1, +C prefer v + N + NB. +C + CALL DORMQR( 'Left', 'Transpose', LDDW, 1, N, DWORK(INIGAM), + $ LDDW, DWORK(ITAU), DWORK(IRHS), LDDW, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C + IF ( NCYC ) THEN +C +C Save the triangular factor of Gamma and the +C corresponding right hand side. +C + CALL DLACPY( 'Upper', N, NCP1, DWORK(INIGAM), LDDW, + $ DWORK(INIR), LDR ) + END IF + ELSE +C +C Compress the current (but not the first) data segment of +C Gamma. +C Workspace: need v + N - 1. +C + CALL MB04OD( 'Full', N, 1, LDDW, DWORK(INIR), LDR, + $ DWORK(INIGAM), LDDW, DWORK(INIH), LDR, + $ DWORK(IRHS), LDDW, DWORK(ITAU), DWORK(JWORK) ) + END IF +C + IUPNT = IUPNT + NOBS + IYPNT = IYPNT + NOBS + 150 CONTINUE +C +C Estimate the reciprocal condition number of the triangular factor +C of the QR decomposition. +C Workspace: need u + 3*N, where +C u = t*L*(N + 1), if NCYCLE = 1; +C u = w, if NCYCLE > 1. +C + CALL DTRCON( '1-norm', 'Upper', 'No Transpose', N, DWORK(INIR), + $ LDR, RCOND, DWORK(IE), IWORK, IERR ) +C + TOLL = TOL + IF ( TOLL.LE.ZERO ) + $ TOLL = DLAMCH( 'Precision' ) + IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN + IWARN = 4 +C +C The least squares problem is ill-conditioned. +C Use SVD to solve it. +C Workspace: need u + 6*N; +C prefer larger. +C + CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, DWORK(INIR+1), + $ LDR ) + ISV = IE + JWORK = ISV + N + CALL DGELSS( N, N, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, + $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + IF ( IERR.GT.0 ) THEN +C +C Return if SVD algorithm did not converge. +C + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) + ELSE +C +C Find the least squares solution using QR decomposition only. +C + CALL DTRSV( 'Upper', 'No Transpose', 'Non Unit', N, + $ DWORK(INIR), LDR, DWORK(INIH), 1 ) + END IF +C +C Return the estimated initial state of the system x0. +C + CALL DCOPY( N, DWORK(INIH), 1, X0, 1 ) +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND +C + RETURN +C +C *** End of IB01RD *** + END diff --git a/modules/cacsd/src/slicot/ib01rd.lo b/modules/cacsd/src/slicot/ib01rd.lo new file mode 100755 index 000000000..827fc73b5 --- /dev/null +++ b/modules/cacsd/src/slicot/ib01rd.lo @@ -0,0 +1,12 @@ +# src/slicot/ib01rd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ib01rd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/inva.f b/modules/cacsd/src/slicot/inva.f new file mode 100755 index 000000000..369e08090 --- /dev/null +++ b/modules/cacsd/src/slicot/inva.f @@ -0,0 +1,114 @@ + subroutine inva(nmax,n,a,z,ftest,eps,ndim,fail,ind) + integer nmax,n,ftest,ndim,ind(n) + logical fail + double precision a(nmax,n),z(nmax,n),eps +c!purpose +c given the upper real schur matrix a +c with 1x1 or 2x2 diagonal blocks, this routine reorders the diagonal +c blocks along with their generalized eigenvalues by constructing equi- +c valence transformation. the transformation is also +c performed on the given (initial) transformation z (resulting from a +c possible previous step or initialized with the identity matrix). +c after reordering, the eigenvalues inside the region specified by the +c function ftest appear at the top. if ndim is their number then the +c ndim first columns of z span the requested subspace. +c!calling sequence +c +c subroutine inva (nmax,n,a,z,ftest,eps,ndim,fail,ind) +c integer nmax,n,ftest,ndim,ind(n) +c logical fail +c double precision a(nmax,n),z(nmax,n),eps +c +c nmax the first dimension of a and z +c n the order of a and z +c *a the matrix whose blocks are to be reordered. +c *z upon return this array is multiplied by the column +c transformation z. +c ftest(ls,alpha,beta,s,p) an integer function describing the +c spectrum of the invariant subspace to be computed: +c when ls=1 ftest checks if alpha/beta is in that spectrum +c when ls=2 ftest checks if the two complex conjugate +c roots with sum s and product p are in that spectrum +c if the answer is positive, ftest=1, otherwise ftest=-1 +c eps the required absolute accuracy of the result +c *ndim an integer giving the dimension of the computed +c invariant subspace +c *fail a logical variable which is false on a normal return, +c true otherwise (when exchng fails) +c *ind an integer working array of dimension at least n +c +c!auxiliary routines +c exchng +c ftest (user defined) +c! +c Copyright SLICOT + external ftest + integer l,ls,ls1,ls2,l1,ll,num,is,l2i,l2k,i,k,ii,istep,ifirst + double precision s,p,alpha,beta + integer iero + common /ierinv/ iero + + iero=0 + fail=.false. + ndim=0 + num=0 + l=0 + ls=1 +c ** construct array ind(i) where : +c ** abs(ind(i)) is the size of the block i +c ** sign(ind(i)) indicates the location of its eigenvalues +c ** (as determined by ftest). +c ** num is the number of elements in this array + do 40 ll=1,n + l=l+ls + if(l.gt.n) go to 50 + l1=l+1 + if(l1.gt.n) go to 20 + if(a(l1,l).eq.0.0d+0) go to 20 +c here a 2x2 block is checked * + ls=2 + s=a(l,l)+a(l1,l1) + p=a(l,l)*a(l1,l1)-a(l,l1)*a(l1,l) + is=ftest(ls,alpha,beta,s,p) + if(iero.gt.0) return + go to 30 +c here a 1x1 block is checked * + 20 ls=1 + is=ftest(ls,a(l,l),1.0d+0,s,p) + if(iero.gt.0) return + 30 num=num+1 + if(is.eq.1) ndim=ndim+ls + 40 ind(num)=ls*is +c ** reorder blocks such that those with positive value +c ** of ind(.) appear first. + 50 l2i=1 + do 90 i=1,num + if(ind(i).gt.0) go to 90 +c if a negative ind(i) is encountered, then search for the first +c positive ind(k) following on it + l2k=l2i + do 60 k=i,num + if(ind(k).lt.0) go to 60 + go to 70 + 60 l2k=l2k-ind(k) +c if there are no positive indices following on a negative one +c then stop + go to 100 +c if a positive ind(k) follows on a negative ind(i) then +c interchange block k before block i by performing k-i swaps + 70 istep=k-i + ls2=ind(k) + l=l2k + do 80 ii=1,istep + ifirst=k-ii + ls1=-ind(ifirst) + l=l-ls1 +c call exchng(a,z,n,l,ls1,ls2,eps,fail,nmax,nmax) + call exch(nmax,n,a,z,l,ls1,ls2) + if (fail) return + 80 ind(ifirst+1)=ind(ifirst) + ind(i)=ls2 + 90 l2i=l2i+ind(i) + 100 fail=.false. + return + end diff --git a/modules/cacsd/src/slicot/inva.lo b/modules/cacsd/src/slicot/inva.lo new file mode 100755 index 000000000..b4fc6da61 --- /dev/null +++ b/modules/cacsd/src/slicot/inva.lo @@ -0,0 +1,12 @@ +# src/slicot/inva.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/inva.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ma02ad.f b/modules/cacsd/src/slicot/ma02ad.f new file mode 100755 index 000000000..242ff45eb --- /dev/null +++ b/modules/cacsd/src/slicot/ma02ad.f @@ -0,0 +1,92 @@ + SUBROUTINE MA02AD( JOB, M, N, A, LDA, B, LDB ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To transpose all or part of a two-dimensional matrix A into +C another matrix B. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the part of the matrix A to be transposed into B +C as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part; +C Otherwise: All of the matrix A. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The m-by-n matrix A. If JOB = 'U', only the upper +C triangle or trapezoid is accessed; if JOB = 'L', only the +C lower triangle or trapezoid is accessed. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C B = A' in the locations specified by JOB. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine DMTRA. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER LDA, LDB, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*) +C .. Local Scalars .. + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. Intrinsic Functions .. + INTRINSIC MIN +C +C .. Executable Statements .. +C + IF( LSAME( JOB, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, MIN( J, M ) + B(J,I) = A(I,J) + 10 CONTINUE + 20 CONTINUE + ELSE IF( LSAME( JOB, 'L' ) ) THEN + DO 40 J = 1, N + DO 30 I = J, M + B(J,I) = A(I,J) + 30 CONTINUE + 40 CONTINUE + ELSE + DO 60 J = 1, N + DO 50 I = 1, M + B(J,I) = A(I,J) + 50 CONTINUE + 60 CONTINUE + END IF +C + RETURN +C *** Last line of MA02AD *** + END diff --git a/modules/cacsd/src/slicot/ma02ad.lo b/modules/cacsd/src/slicot/ma02ad.lo new file mode 100755 index 000000000..e268ad1cb --- /dev/null +++ b/modules/cacsd/src/slicot/ma02ad.lo @@ -0,0 +1,12 @@ +# src/slicot/ma02ad.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ma02ad.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ma02ed.f b/modules/cacsd/src/slicot/ma02ed.f new file mode 100755 index 000000000..b5bf99fcc --- /dev/null +++ b/modules/cacsd/src/slicot/ma02ed.f @@ -0,0 +1,83 @@ + SUBROUTINE MA02ED( UPLO, N, A, LDA ) +C +C RELEASE 3.0, WGS COPYRIGHT 1998. +C +C PURPOSE +C +C To store by symmetry the upper or lower triangle of a symmetric +C matrix, given the other triangle. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which part of the matrix is given as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C For all other values, the array A is not referenced. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N upper triangular part +C (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'), +C of this array must contain the corresponding upper or +C lower triangle of the symmetric matrix A. +C On exit, the leading N-by-N part of this array contains +C the symmetric matrix A with all elements stored. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY +C +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked for errors. +C + IF( LSAME( UPLO, 'L' ) ) THEN +C +C Construct the upper triangle of A. +C + DO 20 J = 2, N + CALL DCOPY( J-1, A(J,1), LDA, A(1,J), 1 ) + 20 CONTINUE +C + ELSE IF( LSAME( UPLO, 'U' ) ) THEN +C +C Construct the lower triangle of A. +C + DO 40 J = 2, N + CALL DCOPY( J-1, A(1,J), 1, A(J,1), LDA ) + 40 CONTINUE +C + END IF + RETURN +C *** Last line of MA02ED *** + END diff --git a/modules/cacsd/src/slicot/ma02ed.lo b/modules/cacsd/src/slicot/ma02ed.lo new file mode 100755 index 000000000..02b6ee0fe --- /dev/null +++ b/modules/cacsd/src/slicot/ma02ed.lo @@ -0,0 +1,12 @@ +# src/slicot/ma02ed.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ma02ed.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/ma02fd.f b/modules/cacsd/src/slicot/ma02fd.f new file mode 100755 index 000000000..6b5b6cc0f --- /dev/null +++ b/modules/cacsd/src/slicot/ma02fd.f @@ -0,0 +1,88 @@ + SUBROUTINE MA02FD( X1, X2, C, S, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To compute the coefficients c and s (c^2 + s^2 = 1) for a modified +C hyperbolic plane rotation, such that, +C +C y1 := 1/c * x1 - s/c * x2 = sqrt(x1^2 - x2^2), +C y2 := -s * y1 + c * x2 = 0, +C +C given two real numbers x1 and x2, satisfying either x1 = x2 = 0, +C or abs(x2) < abs(x1). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C X1 (input/output) DOUBLE PRECISION +C On entry, the real number x1. +C On exit, the real number y1. +C +C X2 (input) DOUBLE PRECISION +C The real number x2. +C The values x1 and x2 should satisfy either x1 = x2 = 0, or +C abs(x2) < abs(x1). +C +C C (output) DOUBLE PRECISION +C The cosines c of the modified hyperbolic plane rotation. +C +C S (output) DOUBLE PRECISION +C The sines s of the modified hyperbolic plane rotation. +C +C Error Indicator +C +C INFO INTEGER +C = 0: succesful exit; +C = 1: if abs(x2) >= abs(x1) and either x1 <> 0 or x2 <> 0. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. +C +C KEYWORDS +C +C Orthogonal transformation, plane rotation. +C +C ***************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION X1, X2, C, S + INTEGER INFO +C .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +C .. Executable Statements .. +C + IF ( ( X1.NE.ZERO .OR. X2.NE.ZERO ) .AND. + $ ABS( X2 ).GE.ABS( X1 ) ) THEN + INFO = 1 + ELSE + INFO = 0 + IF ( X1.EQ.ZERO ) THEN + S = ZERO + C = ONE + ELSE + S = X2 / X1 +C +C No overflows could appear in the next statement; underflows +C are possible if X2 is tiny and X1 is huge, but then +C abs(C) = ONE - delta, +C where delta is much less than machine precision. +C + C = SIGN( SQRT( ONE - S ) * SQRT( ONE + S ), X1 ) + X1 = C * X1 + END IF + END IF +C + RETURN +C *** Last line of MA02FD *** + END diff --git a/modules/cacsd/src/slicot/ma02fd.lo b/modules/cacsd/src/slicot/ma02fd.lo new file mode 100755 index 000000000..5770d42c3 --- /dev/null +++ b/modules/cacsd/src/slicot/ma02fd.lo @@ -0,0 +1,12 @@ +# src/slicot/ma02fd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ma02fd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb01pd.f b/modules/cacsd/src/slicot/mb01pd.f new file mode 100755 index 000000000..7852fedac --- /dev/null +++ b/modules/cacsd/src/slicot/mb01pd.f @@ -0,0 +1,251 @@ + SUBROUTINE MB01PD( SCUN, TYPE, M, N, KL, KU, ANRM, NBL, NROWS, A, + $ LDA, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER*1 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( .NOT.LSCALE .AND. .NOT.LSAME( SCUN, 'U' ) ) THEN + INFO = -1 + ELSE 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 + IF( NBL.GT.0 ) THEN + ISUM = 0 + DO 10 I = 1, NBL + ISUM = ISUM + NROWS(I) + 10 CONTINUE + END IF +C + IF( ITYPE.EQ.-1 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. N.NE.M ) ) THEN + INFO = -4 + ELSE IF( ANRM.LT.ZERO ) THEN + INFO = -7 + ELSE IF( NBL.LT.0 ) THEN + INFO = -8 + ELSE IF( NBL.GT.0 .AND. ISUM.NE.MN ) THEN + INFO = -9 + ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ITYPE.GE.4 ) THEN + IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN + INFO = -5 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) + $ THEN + INFO = -6 + ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. + $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. + $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN + INFO = -11 + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MN.EQ.0 .OR. ANRM.EQ.ZERO ) + $ RETURN +C + IF ( FIRST ) THEN +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + FIRST = .FALSE. + END IF +C + IF ( LSCALE ) THEN +C +C Scale A, if its norm is outside range [SMLNUM,BIGNUM]. +C + IF( ANRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL MB01QD( TYPE, M, N, KL, KU, ANRM, SMLNUM, NBL, NROWS, + $ A, LDA, INFO ) + ELSE IF( ANRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL MB01QD( TYPE, M, N, KL, KU, ANRM, BIGNUM, NBL, NROWS, + $ A, LDA, INFO ) + END IF +C + ELSE +C +C Undo scaling. +C + IF( ANRM.LT.SMLNUM ) THEN + CALL MB01QD( TYPE, M, N, KL, KU, SMLNUM, ANRM, NBL, NROWS, + $ A, LDA, INFO ) + ELSE IF( ANRM.GT.BIGNUM ) THEN + CALL MB01QD( TYPE, M, N, KL, KU, BIGNUM, ANRM, NBL, NROWS, + $ A, LDA, INFO ) + END IF + END IF +C + RETURN +C *** Last line of MB01PD *** + END diff --git a/modules/cacsd/src/slicot/mb01pd.lo b/modules/cacsd/src/slicot/mb01pd.lo new file mode 100755 index 000000000..aad3f64f4 --- /dev/null +++ b/modules/cacsd/src/slicot/mb01pd.lo @@ -0,0 +1,12 @@ +# src/slicot/mb01pd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb01pd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb01qd.f b/modules/cacsd/src/slicot/mb01qd.f new file mode 100755 index 000000000..a17a2aa2f --- /dev/null +++ b/modules/cacsd/src/slicot/mb01qd.f @@ -0,0 +1,318 @@ + SUBROUTINE MB01QD( TYPE, M, N, KL, KU, CFROM, CTO, NBL, NROWS, A, + $ LDA, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To multiply the M by N real matrix A by the real scalar CTO/CFROM. +C This is done without over/underflow as long as the final result +C CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that +C A may be full, (block) upper triangular, (block) lower triangular, +C (block) upper Hessenberg, or banded. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPE CHARACTER*1 +C TYPE indices the storage type of the input matrix. +C = 'G': A is a full matrix. +C = 'L': A is a (block) lower triangular matrix. +C = 'U': A is a (block) upper triangular matrix. +C = 'H': A is a (block) upper Hessenberg matrix. +C = 'B': A is a symmetric band matrix with lower bandwidth +C KL and upper bandwidth KU and with the only the +C lower half stored. +C = 'Q': A is a symmetric band matrix with lower bandwidth +C KL and upper bandwidth KU and with the only the +C upper half stored. +C = 'Z': A is a band matrix with lower bandwidth KL and +C upper bandwidth KU. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C KL (input) INTEGER +C The lower bandwidth of A. Referenced only if TYPE = 'B', +C 'Q' or 'Z'. +C +C KU (input) INTEGER +C The upper bandwidth of A. Referenced only if TYPE = 'B', +C 'Q' or 'Z'. +C +C CFROM (input) DOUBLE PRECISION +C CTO (input) DOUBLE PRECISION +C The matrix A is multiplied by CTO/CFROM. A(I,J) is +C computed without over/underflow if the final result +C CTO*A(I,J)/CFROM can be represented without over/ +C underflow. CFROM must be nonzero. +C +C NBL (input) INTEGER +C The number of diagonal blocks of the matrix A, if it has a +C block structure. To specify that matrix A has no block +C structure, set NBL = 0. NBL >= 0. +C +C NROWS (input) INTEGER array, dimension max(1,NBL) +C NROWS(i) contains the number of rows and columns of the +C i-th diagonal block of matrix A. The sum of the values +C NROWS(i), for i = 1: NBL, should be equal to min(M,N). +C The array NROWS is not referenced if NBL = 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C The matrix to be multiplied by CTO/CFROM. See TYPE for +C the storage type. +C +C LDA (input) INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C Error Indicator +C +C INFO INTEGER +C Not used in this implementation. +C +C METHOD +C +C Matrix A is multiplied by the real scalar CTO/CFROM, taking into +C account the specified storage mode of the matrix. +C MB01QD is a version of the LAPACK routine DLASCL, modified for +C dealing with block triangular, or block Hessenberg matrices. +C For efficiency, no tests of the input scalar parameters are +C performed. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N, NBL + DOUBLE PRECISION CFROM, CTO +C .. +C .. Array Arguments .. + INTEGER NROWS ( * ) + DOUBLE PRECISION A( LDA, * ) +C .. +C .. Local Scalars .. + LOGICAL DONE, NOBLC + INTEGER I, IFIN, ITYPE, J, JFIN, JINI, K, K1, K2, K3, + $ K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. +C .. Executable Statements .. +C + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE + ITYPE = 6 + END IF +C +C Quick return if possible. +C + IF( MIN( M, N ).EQ.0 ) + $ RETURN +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +C + CFROMC = CFROM + CTOC = CTO +C + 10 CONTINUE + CFROM1 = CFROMC*SMLNUM + CTO1 = CTOC / BIGNUM + IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN + MUL = SMLNUM + DONE = .FALSE. + CFROMC = CFROM1 + ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN + MUL = BIGNUM + DONE = .FALSE. + CTOC = CTO1 + ELSE + MUL = CTOC / CFROMC + DONE = .TRUE. + END IF +C + NOBLC = NBL.EQ.0 +C + IF( ITYPE.EQ.0 ) THEN +C +C Full matrix +C + DO 30 J = 1, N + DO 20 I = 1, M + A( I, J ) = A( I, J )*MUL + 20 CONTINUE + 30 CONTINUE +C + ELSE IF( ITYPE.EQ.1 ) THEN +C + IF ( NOBLC ) THEN +C +C Lower triangular matrix +C + DO 50 J = 1, N + DO 40 I = J, M + A( I, J ) = A( I, J )*MUL + 40 CONTINUE + 50 CONTINUE +C + ELSE +C +C Block lower triangular matrix +C + JFIN = 0 + DO 80 K = 1, NBL + JINI = JFIN + 1 + JFIN = JFIN + NROWS( K ) + DO 70 J = JINI, JFIN + DO 60 I = JINI, M + A( I, J ) = A( I, J )*MUL + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + END IF +C + ELSE IF( ITYPE.EQ.2 ) THEN +C + IF ( NOBLC ) THEN +C +C Upper triangular matrix +C + DO 100 J = 1, N + DO 90 I = 1, MIN( J, M ) + A( I, J ) = A( I, J )*MUL + 90 CONTINUE + 100 CONTINUE +C + ELSE +C +C Block upper triangular matrix +C + JFIN = 0 + DO 130 K = 1, NBL + JINI = JFIN + 1 + JFIN = JFIN + NROWS( K ) + IF ( K.EQ.NBL ) JFIN = N + DO 120 J = JINI, JFIN + DO 110 I = 1, MIN( JFIN, M ) + A( I, J ) = A( I, J )*MUL + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + END IF +C + ELSE IF( ITYPE.EQ.3 ) THEN +C + IF ( NOBLC ) THEN +C +C Upper Hessenberg matrix +C + DO 150 J = 1, N + DO 140 I = 1, MIN( J+1, M ) + A( I, J ) = A( I, J )*MUL + 140 CONTINUE + 150 CONTINUE +C + ELSE +C +C Block upper Hessenberg matrix +C + JFIN = 0 + DO 180 K = 1, NBL + JINI = JFIN + 1 + JFIN = JFIN + NROWS( K ) +C + IF ( K.EQ.NBL ) THEN + JFIN = N + IFIN = N + ELSE + IFIN = JFIN + NROWS( K+1 ) + END IF +C + DO 170 J = JINI, JFIN + DO 160 I = 1, MIN( IFIN, M ) + A( I, J ) = A( I, J )*MUL + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE + END IF +C + ELSE IF( ITYPE.EQ.4 ) THEN +C +C Lower half of a symmetric band matrix +C + K3 = KL + 1 + K4 = N + 1 + DO 200 J = 1, N + DO 190 I = 1, MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 190 CONTINUE + 200 CONTINUE +C + ELSE IF( ITYPE.EQ.5 ) THEN +C +C Upper half of a symmetric band matrix +C + K1 = KU + 2 + K3 = KU + 1 + DO 220 J = 1, N + DO 210 I = MAX( K1-J, 1 ), K3 + A( I, J ) = A( I, J )*MUL + 210 CONTINUE + 220 CONTINUE +C + ELSE IF( ITYPE.EQ.6 ) THEN +C +C Band matrix +C + K1 = KL + KU + 2 + K2 = KL + 1 + K3 = 2*KL + KU + 1 + K4 = KL + KU + 1 + M + DO 240 J = 1, N + DO 230 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 230 CONTINUE + 240 CONTINUE +C + END IF +C + IF( .NOT.DONE ) + $ GO TO 10 +C + RETURN +C *** Last line of MB01QD *** + END diff --git a/modules/cacsd/src/slicot/mb01qd.lo b/modules/cacsd/src/slicot/mb01qd.lo new file mode 100755 index 000000000..11b518130 --- /dev/null +++ b/modules/cacsd/src/slicot/mb01qd.lo @@ -0,0 +1,12 @@ +# src/slicot/mb01qd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb01qd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb01rd.f b/modules/cacsd/src/slicot/mb01rd.f new file mode 100755 index 000000000..efa36ccac --- /dev/null +++ b/modules/cacsd/src/slicot/mb01rd.f @@ -0,0 +1,328 @@ + SUBROUTINE MB01RD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, + $ X, LDX, DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 - +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*1 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 + IF ( MAX( N, 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. 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 DSCAL( N, HALF, X, LDX+1 ) + CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', M, N, BETA, + $ X, LDX, DWORK, LDW ) +C +C Compute Y = alpha*V + W*op( A )' in R. First, set to zero the +C strictly triangular part of R not specified by UPLO. That part +C will then contain beta*stri( B ). +C + IF ( ALPHA.NE.ZERO ) THEN + IF ( M.GT.1 ) THEN + IF ( LUPLO ) THEN + CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, R(2,1), LDR ) + ELSE + CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, R(1,2), LDR ) + END IF + END IF + CALL DSCAL( M, HALF, R, LDR+1 ) + END IF +C + CALL DGEMM( 'No transpose', NTRAN, M, M, N, ONE, DWORK, LDW, A, + $ LDA, ALPHA, R, LDR ) +C +C Add the term corresponding to B', with B = op( A )*T*op( A )'. +C + IF( LUPLO ) THEN +C + DO 20 J = 1, M + CALL DAXPY( J, ONE, R(J,1), LDR, R(1,J), 1 ) + 20 CONTINUE +C + ELSE +C + DO 30 J = 1, M + CALL DAXPY( J, ONE, R(1,J), 1, R(J,1), LDR ) + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB01RD *** + END diff --git a/modules/cacsd/src/slicot/mb01rd.lo b/modules/cacsd/src/slicot/mb01rd.lo new file mode 100755 index 000000000..6edd54bbf --- /dev/null +++ b/modules/cacsd/src/slicot/mb01rd.lo @@ -0,0 +1,12 @@ +# src/slicot/mb01rd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb01rd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb01ru.f b/modules/cacsd/src/slicot/mb01ru.f new file mode 100755 index 000000000..f0f31cb8a --- /dev/null +++ b/modules/cacsd/src/slicot/mb01ru.f @@ -0,0 +1,268 @@ + SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, + $ X, LDX, DWORK, LDWORK, INFO ) +C +C RELEASE 3.0, WGS COPYRIGHT 1997. +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 - +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.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 ) 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 + IF ( N.EQ.0 ) + $ RETURN +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 DSCAL( N, TWO, X, LDX+1 ) + 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 DSCAL( N, TWO, X, LDX+1 ) + CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, M, A, LDA, ALPHA, + $ R, LDR ) +C + END IF +C + RETURN +C *** Last line of MB01RU *** + END diff --git a/modules/cacsd/src/slicot/mb01ru.lo b/modules/cacsd/src/slicot/mb01ru.lo new file mode 100755 index 000000000..bb1888884 --- /dev/null +++ b/modules/cacsd/src/slicot/mb01ru.lo @@ -0,0 +1,12 @@ +# src/slicot/mb01ru.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb01ru.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb01rx.f b/modules/cacsd/src/slicot/mb01rx.f new file mode 100755 index 000000000..8e7038a8d --- /dev/null +++ b/modules/cacsd/src/slicot/mb01rx.f @@ -0,0 +1,302 @@ + SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, + $ A, LDA, B, LDB, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 - +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 ) 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 + IF ( N.EQ.0 ) + $ RETURN +C +C General case: beta <> 0. +C Compute the required triangle of (1) or (2) using BLAS 2 +C operations. +C + IF( LSIDE ) THEN + IF( LUPLO ) THEN + IF ( LTRANS ) THEN + DO 10 J = 1, M + CALL DGEMV( TRANS, N, J, BETA, A, LDA, B(1,J), 1, + $ ALPHA, R(1,J), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, M + CALL DGEMV( TRANS, J, N, BETA, A, LDA, B(1,J), 1, + $ ALPHA, R(1,J), 1 ) + 20 CONTINUE + END IF + ELSE + IF ( LTRANS ) THEN + DO 30 J = 1, M + CALL DGEMV( TRANS, N, M-J+1, BETA, A(1,J), LDA, + $ B(1,J), 1, ALPHA, R(J,J), 1 ) + 30 CONTINUE + ELSE + DO 40 J = 1, M + CALL DGEMV( TRANS, M-J+1, N, BETA, A(J,1), LDA, + $ B(1,J), 1, ALPHA, R(J,J), 1 ) + 40 CONTINUE + END IF + END IF +C + ELSE + IF( LUPLO ) THEN + IF( LTRANS ) THEN + DO 50 J = 1, M + CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(J,1), + $ LDA, ALPHA, R(1,J), 1 ) + 50 CONTINUE + ELSE + DO 60 J = 1, M + CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(1,J), + $ 1, ALPHA, R(1,J), 1 ) + 60 CONTINUE + END IF + ELSE + IF( LTRANS ) THEN + DO 70 J = 1, M + CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), + $ LDB, A(J,1), LDA, ALPHA, R(J,J), 1 ) + 70 CONTINUE + ELSE + DO 80 J = 1, M + CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), + $ LDB, A(1,J), 1, ALPHA, R(J,J), 1 ) + 80 CONTINUE + END IF + END IF + END IF +C + RETURN +C *** Last line of MB01RX *** + END diff --git a/modules/cacsd/src/slicot/mb01rx.lo b/modules/cacsd/src/slicot/mb01rx.lo new file mode 100755 index 000000000..3b811b37d --- /dev/null +++ b/modules/cacsd/src/slicot/mb01rx.lo @@ -0,0 +1,12 @@ +# src/slicot/mb01rx.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb01rx.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb01ry.f b/modules/cacsd/src/slicot/mb01ry.f new file mode 100755 index 000000000..6c7901b51 --- /dev/null +++ b/modules/cacsd/src/slicot/mb01ry.f @@ -0,0 +1,413 @@ + SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H, + $ LDH, B, LDB, DWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To compute either the upper or lower triangular part of one of the +C matrix formulas +C _ +C R = alpha*R + beta*op( H )*B, (1) +C _ +C R = alpha*R + beta*B*op( H ), (2) +C _ +C where alpha and beta are scalars, H, B, R, and R are m-by-m +C matrices, H is an upper Hessenberg matrix, and op( H ) is one of +C +C op( H ) = H or op( H ) = H', the transpose of H. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the Hessenberg matrix H appears on the +C left or right in the matrix product as follows: +C _ +C = 'L': R = alpha*R + beta*op( H )*B; +C _ +C = 'R': R = alpha*R + beta*B*op( H ). +C +C UPLO CHARACTER*1 _ +C Specifies which triangles of the matrices R and R are +C computed and given, respectively, as follows: +C = 'U': the upper triangular part; +C = 'L': the lower triangular part. +C +C TRANS CHARACTER*1 +C Specifies the form of op( H ) to be used in the matrix +C multiplication as follows: +C = 'N': op( H ) = H; +C = 'T': op( H ) = H'; +C = 'C': op( H ) = H'. +C +C Input/Output Parameters +C +C M (input) INTEGER _ +C The order of the matrices R, R, H and B. M >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then R need not be +C set before entry. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then H and B are not +C referenced. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry with UPLO = 'U', the leading M-by-M upper +C triangular part of this array must contain the upper +C triangular part of the matrix R; the strictly lower +C triangular part of the array is not referenced. +C On entry with UPLO = 'L', the leading M-by-M lower +C triangular part of this array must contain the lower +C triangular part of the matrix R; the strictly upper +C triangular part of the array is not referenced. +C On exit, the leading M-by-M upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C H (input) DOUBLE PRECISION array, dimension (LDH,M) +C On entry, the leading M-by-M upper Hessenberg part of +C this array must contain the upper Hessenberg part of the +C matrix H. +C The elements below the subdiagonal are not referenced, +C except possibly for those in the first column, which +C could be overwritten, but are restored on exit. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C LDWORK >= M, if beta <> 0 and SIDE = 'L'; +C LDWORK >= 0, if beta = 0 or SIDE = 'R'. +C This array is not referenced when beta = 0 or SIDE = 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression is efficiently evaluated taking the +C Hessenberg/triangular structure into account. BLAS 2 operations +C are used. A block algorithm can be constructed; it can use BLAS 3 +C GEMM operations for most computations, and calls of this BLAS 2 +C algorithm for computing the triangles. +C +C FURTHER COMMENTS +C +C The main application of this routine is when the result should +C be a symmetric matrix, e.g., when B = X*op( H )', for (1), or +C B = op( H )'*X, for (2), where B is already available and X = X'. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDB, LDH, LDR, M + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), DWORK(*), H(LDH,*), R(LDR,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRANS, LUPLO + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLASCL, DLASET, DSCAL, DSWAP, + $ DTRMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LUPLO = LSAME( UPLO, 'U' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -2 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( LDR.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDH.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01RY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ZERO ) THEN +C +C Special case when both alpha = 0 and beta = 0. +C + CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case beta = 0. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) + END IF + RETURN + END IF +C +C General case: beta <> 0. +C Compute the required triangle of (1) or (2) using BLAS 2 +C operations. +C + IF( LSIDE ) THEN +C +C To avoid repeated references to the subdiagonal elements of H, +C these are swapped with the corresponding elements of H in the +C first column, and are finally restored. +C + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + IF( LUPLO ) THEN + IF ( LTRANS ) THEN +C + DO 20 J = 1, M +C +C Multiply the transposed upper triangle of the leading +C j-by-j submatrix of H by the leading part of the j-th +C column of B. +C + CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, + $ DWORK, 1 ) +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 10 I = 1, MIN( J, M - 1 ) + R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) + + $ H( I+1, 1 )*B( I+1, J ) ) + 10 CONTINUE +C + 20 CONTINUE +C + R( M, M ) = ALPHA*R( M, M ) + BETA*DWORK( M ) +C + ELSE +C + DO 40 J = 1, M +C +C Multiply the upper triangle of the leading j-by-j +C submatrix of H by the leading part of the j-th column +C of B. +C + CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, + $ DWORK, 1 ) + IF( J.LT.M ) THEN +C +C Multiply the remaining right part of the leading +C j-by-M submatrix of H by the trailing part of the +C j-th column of B. +C + CALL DGEMV( TRANS, J, M-J, BETA, H( 1, J+1 ), LDH, + $ B( J+1, J ), 1, ALPHA, R( 1, J ), 1 ) + ELSE + CALL DSCAL( M, ALPHA, R( 1, M ), 1 ) + END IF +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + R( 1, J ) = R( 1, J ) + BETA*DWORK( 1 ) +C + DO 30 I = 2, J + R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + + $ H( I, 1 )*B( I-1, J ) ) + 30 CONTINUE +C + 40 CONTINUE +C + END IF +C + ELSE +C + IF ( LTRANS ) THEN +C + DO 60 J = M, 1, -1 +C +C Multiply the transposed upper triangle of the trailing +C (M-j+1)-by-(M-j+1) submatrix of H by the trailing part +C of the j-th column of B. +C + CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, + $ H( J, J ), LDH, DWORK( J ), 1 ) + IF( J.GT.1 ) THEN +C +C Multiply the remaining left part of the trailing +C (M-j+1)-by-(j-1) submatrix of H' by the leading +C part of the j-th column of B. +C + CALL DGEMV( TRANS, J-1, M-J+1, BETA, H( 1, J ), + $ LDH, B( 1, J ), 1, ALPHA, R( J, J ), + $ 1 ) + ELSE + CALL DSCAL( M, ALPHA, R( 1, 1 ), 1 ) + END IF +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 50 I = J, M - 1 + R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + + $ H( I+1, 1 )*B( I+1, J ) ) + 50 CONTINUE +C + R( M, J ) = R( M, J ) + BETA*DWORK( M ) + 60 CONTINUE +C + ELSE +C + DO 80 J = M, 1, -1 +C +C Multiply the upper triangle of the trailing +C (M-j+1)-by-(M-j+1) submatrix of H by the trailing +C part of the j-th column of B. +C + CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, + $ H( J, J ), LDH, DWORK( J ), 1 ) +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 70 I = MAX( J, 2 ), M + R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) + $ + H( I, 1 )*B( I-1, J ) ) + 70 CONTINUE +C + 80 CONTINUE +C + R( 1, 1 ) = ALPHA*R( 1, 1 ) + BETA*DWORK( 1 ) +C + END IF + END IF +C + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + ELSE +C +C Row-wise calculations are used for H, if SIDE = 'R' and +C TRANS = 'T'. +C + IF( LUPLO ) THEN + IF( LTRANS ) THEN + R( 1, 1 ) = ALPHA*R( 1, 1 ) + + $ BETA*DDOT( M, B, LDB, H, LDH ) +C + DO 90 J = 2, M + CALL DGEMV( 'NoTranspose', J, M-J+2, BETA, + $ B( 1, J-1 ), LDB, H( J, J-1 ), LDH, + $ ALPHA, R( 1, J ), 1 ) + 90 CONTINUE +C + ELSE +C + DO 100 J = 1, M - 1 + CALL DGEMV( 'NoTranspose', J, J+1, BETA, B, LDB, + $ H( 1, J ), 1, ALPHA, R( 1, J ), 1 ) + 100 CONTINUE +C + CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, + $ H( 1, M ), 1, ALPHA, R( 1, M ), 1 ) +C + END IF +C + ELSE +C + IF( LTRANS ) THEN +C + CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, H, LDH, + $ ALPHA, R( 1, 1 ), 1 ) +C + DO 110 J = 2, M + CALL DGEMV( 'NoTranspose', M-J+1, M-J+2, BETA, + $ B( J, J-1 ), LDB, H( J, J-1 ), LDH, ALPHA, + $ R( J, J ), 1 ) + 110 CONTINUE +C + ELSE +C + DO 120 J = 1, M - 1 + CALL DGEMV( 'NoTranspose', M-J+1, J+1, BETA, + $ B( J, 1 ), LDB, H( 1, J ), 1, ALPHA, + $ R( J, J ), 1 ) + 120 CONTINUE +C + R( M, M ) = ALPHA*R( M, M ) + + $ BETA*DDOT( M, B( M, 1 ), LDB, H( 1, M ), 1 ) +C + END IF + END IF + END IF +C + RETURN +C *** Last line of MB01RY *** + END diff --git a/modules/cacsd/src/slicot/mb01ry.lo b/modules/cacsd/src/slicot/mb01ry.lo new file mode 100755 index 000000000..6258adac1 --- /dev/null +++ b/modules/cacsd/src/slicot/mb01ry.lo @@ -0,0 +1,12 @@ +# src/slicot/mb01ry.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb01ry.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb01sd.f b/modules/cacsd/src/slicot/mb01sd.f new file mode 100755 index 000000000..d96c2b083 --- /dev/null +++ b/modules/cacsd/src/slicot/mb01sd.f @@ -0,0 +1,107 @@ + SUBROUTINE MB01SD( JOBS, M, N, A, LDA, R, C ) +C +C RELEASE 3.0, WGS COPYRIGHT 1998. +C +C PURPOSE +C +C To scale a general M-by-N matrix A using the row and column +C scaling factors in the vectors R and C. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBS CHARACTER*1 +C Specifies the scaling operation to be done, as follows: +C = 'R': row scaling, i.e., A will be premultiplied +C by diag(R); +C = 'C': column scaling, i.e., A will be postmultiplied +C by diag(C); +C = 'B': both row and column scaling, i.e., A will be +C replaced by diag(R) * A * diag(C). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the M-by-N matrix A. +C On exit, the scaled matrix. See JOBS for the form of the +C scaled matrix. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C R (input) DOUBLE PRECISION array, dimension (M) +C The row scale factors for A. +C R is not referenced if JOBS = 'C'. +C +C C (input) DOUBLE PRECISION array, dimension (N) +C The column scale factors for A. +C C is not referenced if JOBS = 'R'. +C +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, April 1998. +C Based on the RASP routine DMSCAL. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER JOBS + INTEGER LDA, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), C(*), R(*) +C .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION CJ +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. Executable Statements .. +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +C + IF( LSAME( JOBS, 'C' ) ) THEN +C +C Column scaling, no row scaling. +C + DO 20 J = 1, N + CJ = C(J) + DO 10 I = 1, M + A(I,J) = CJ*A(I,J) + 10 CONTINUE + 20 CONTINUE + ELSE IF( LSAME( JOBS, 'R' ) ) THEN +C +C Row scaling, no column scaling. +C + DO 40 J = 1, N + DO 30 I = 1, M + A(I,J) = R(I)*A(I,J) + 30 CONTINUE + 40 CONTINUE + ELSE IF( LSAME( JOBS, 'B' ) ) THEN +C +C Row and column scaling. +C + DO 60 J = 1, N + CJ = C(J) + DO 50 I = 1, M + A(I,J) = CJ*R(I)*A(I,J) + 50 CONTINUE + 60 CONTINUE + END IF +C + RETURN +C *** Last line of MB01SD *** + END diff --git a/modules/cacsd/src/slicot/mb01sd.lo b/modules/cacsd/src/slicot/mb01sd.lo new file mode 100755 index 000000000..1131de5a9 --- /dev/null +++ b/modules/cacsd/src/slicot/mb01sd.lo @@ -0,0 +1,12 @@ +# src/slicot/mb01sd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb01sd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb01td.f b/modules/cacsd/src/slicot/mb01td.f new file mode 100755 index 000000000..e5b15e7aa --- /dev/null +++ b/modules/cacsd/src/slicot/mb01td.f @@ -0,0 +1,157 @@ + SUBROUTINE MB01TD( N, A, LDA, B, LDB, DWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To compute the matrix product A * B, where A and B are upper +C quasi-triangular matrices (that is, block upper triangular with +C 1-by-1 or 2-by-2 diagonal blocks) with the same structure. +C The result is returned in the array B. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and B. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C upper quasi-triangular matrix A. The elements below the +C subdiagonal are not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix B, with the same +C structure as matrix A. +C On exit, the leading N-by-N part of this array contains +C the computed product A * B, with the same structure as +C on entry. +C The elements below the subdiagonal are not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N-1) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrices A and B have not the same structure, +C and/or A and B are not upper quasi-triangular. +C +C METHOD +C +C The matrix product A * B is computed column by column, using +C BLAS 2 and BLAS 1 operations. +C +C FURTHER COMMENTS +C +C This routine can be used, for instance, for computing powers of +C a real Schur form matrix. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C V. Sima, Feb. 2000. +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) +C .. Local Scalars .. + INTEGER I, J, JMIN, JMNM +C .. External Subroutines .. + EXTERNAL DAXPY, DTRMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01TD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF ( N.EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.1 ) THEN + B(1,1) = A(1,1)*B(1,1) + RETURN + END IF +C +C Test the upper quasi-triangular structure of A and B for identity. +C + DO 10 I = 1, N - 1 + IF ( A(I+1,I).EQ.ZERO ) THEN + IF ( B(I+1,I).NE.ZERO ) THEN + INFO = 1 + RETURN + END IF + ELSE IF ( I.LT.N-1 ) THEN + IF ( A(I+2,I+1).NE.ZERO ) THEN + INFO = 1 + RETURN + END IF + END IF + 10 CONTINUE +C + DO 30 J = 1, N + JMIN = MIN( J+1, N ) + JMNM = MIN( JMIN, N-1 ) +C +C Compute the contribution of the subdiagonal of A to the +C j-th column of the product. +C + DO 20 I = 1, JMNM + DWORK(I) = A(I+1,I)*B(I,J) + 20 CONTINUE +C +C Multiply the upper triangle of A by the j-th column of B, +C and add to the above result. +C + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', JMIN, A, LDA, + $ B(1,J), 1 ) + CALL DAXPY( JMNM, ONE, DWORK, 1, B(2,J), 1 ) + 30 CONTINUE +C + RETURN +C *** Last line of MB01TD *** + END diff --git a/modules/cacsd/src/slicot/mb01td.lo b/modules/cacsd/src/slicot/mb01td.lo new file mode 100755 index 000000000..0b9f97cbd --- /dev/null +++ b/modules/cacsd/src/slicot/mb01td.lo @@ -0,0 +1,12 @@ +# src/slicot/mb01td.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb01td.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb01ud.f b/modules/cacsd/src/slicot/mb01ud.f new file mode 100755 index 000000000..7ca0b11df --- /dev/null +++ b/modules/cacsd/src/slicot/mb01ud.f @@ -0,0 +1,222 @@ + SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B, + $ LDB, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To compute one of the matrix products +C +C B = alpha*op( H ) * A, or B = alpha*A * op( H ), +C +C where alpha is a scalar, A and B are m-by-n matrices, H is an +C upper Hessenberg matrix, and op( H ) is one of +C +C op( H ) = H or op( H ) = H', the transpose of H. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the Hessenberg matrix H appears on the +C left or right in the matrix product as follows: +C = 'L': B = alpha*op( H ) * A; +C = 'R': B = alpha*A * op( H ). +C +C TRANS CHARACTER*1 +C Specifies the form of op( H ) to be used in the matrix +C multiplication as follows: +C = 'N': op( H ) = H; +C = 'T': op( H ) = H'; +C = 'C': op( H ) = H'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices A and B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices A and B. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then H is not +C referenced and A need not be set before entry. +C +C H (input) DOUBLE PRECISION array, dimension (LDH,k) +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C On entry with SIDE = 'L', the leading M-by-M upper +C Hessenberg part of this array must contain the upper +C Hessenberg matrix H. +C On entry with SIDE = 'R', the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C Hessenberg matrix H. +C The elements below the subdiagonal are not referenced, +C except possibly for those in the first column, which +C could be overwritten, but are restored on exit. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,k), +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,N) +C The leading M-by-N part of this array contains the +C computed product. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The required matrix product is computed in two steps. In the first +C step, the upper triangle of H is used; in the second step, the +C contribution of the subdiagonal is added. A fast BLAS 3 DTRMM +C operation is used in the first step. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, LDB, LDH, M, N + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), H(LDH,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRANS + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLACPY, DLASET, DSWAP, DTRMM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR. + $ ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01UD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF ( MIN( M, N ).EQ.0 ) + $ RETURN +C + IF( ALPHA.EQ.ZERO ) THEN +C +C Set B to zero and return. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) + RETURN + END IF +C +C Copy A in B and compute one of the matrix products +C B = alpha*op( triu( H ) ) * A, or +C B = alpha*A * op( triu( H ) ), +C involving the upper triangle of H. +C + CALL DLACPY( 'Full', M, N, A, LDA, B, LDB ) + CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, + $ LDH, B, LDB ) +C +C Add the contribution of the subdiagonal of H. +C If SIDE = 'L', the subdiagonal of H is swapped with the +C corresponding elements in the first column of H, and the +C calculations are organized for column operations. +C + IF( LSIDE ) THEN + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) + IF( LTRANS ) THEN + DO 20 J = 1, N + DO 10 I = 1, M - 1 + B( I, J ) = B( I, J ) + ALPHA*H( I+1, 1 )*A( I+1, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = 2, M + B( I, J ) = B( I, J ) + ALPHA*H( I, 1 )*A( I-1, J ) + 30 CONTINUE + 40 CONTINUE + END IF + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + ELSE +C + IF( LTRANS ) THEN + DO 50 J = 1, N - 1 + IF ( H( J+1, J ).NE.ZERO ) + $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J ), 1, + $ B( 1, J+1 ), 1 ) + 50 CONTINUE + ELSE + DO 60 J = 1, N - 1 + IF ( H( J+1, J ).NE.ZERO ) + $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J+1 ), 1, + $ B( 1, J ), 1 ) + 60 CONTINUE + END IF + END IF +C + RETURN +C *** Last line of MB01UD *** + END diff --git a/modules/cacsd/src/slicot/mb01ud.lo b/modules/cacsd/src/slicot/mb01ud.lo new file mode 100755 index 000000000..dc7ae8067 --- /dev/null +++ b/modules/cacsd/src/slicot/mb01ud.lo @@ -0,0 +1,12 @@ +# src/slicot/mb01ud.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb01ud.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb01vd.f b/modules/cacsd/src/slicot/mb01vd.f new file mode 100755 index 000000000..591d495e1 --- /dev/null +++ b/modules/cacsd/src/slicot/mb01vd.f @@ -0,0 +1,1677 @@ + SUBROUTINE MB01VD( TRANA, TRANB, MA, NA, MB, NB, ALPHA, BETA, + $ A, LDA, B, LDB, C, LDC, MC, NC, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To perform the following matrix operation +C +C C = alpha*kron( op(A), op(B) ) + beta*C, +C +C where alpha and beta are real scalars, op(M) is either matrix M or +C its transpose, M', and kron( X, Y ) denotes the Kronecker product +C of the matrices X and Y. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used as follows: +C = 'N': op(A) = A; +C = 'T': op(A) = A'; +C = 'C': op(A) = A'. +C +C TRANB CHARACTER*1 +C Specifies the form of op(B) to be used as follows: +C = 'N': op(B) = B; +C = 'T': op(B) = B'; +C = 'C': op(B) = B'. +C +C Input/Output Parameters +C +C MA (input) INTEGER +C The number of rows of the matrix op(A). MA >= 0. +C +C NA (input) INTEGER +C The number of columns of the matrix op(A). NA >= 0. +C +C MB (input) INTEGER +C The number of rows of the matrix op(B). MB >= 0. +C +C NB (input) INTEGER +C The number of columns of the matrix op(B). NB >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then A and B need not +C be set before entry. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then C need not be +C set before entry. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,ka), +C where ka is NA when TRANA = 'N', and is MA otherwise. +C If TRANA = 'N', the leading MA-by-NA part of this array +C must contain the matrix A; otherwise, the leading NA-by-MA +C part of this array must contain the matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= max(1,MA), if TRANA = 'N'; +C LDA >= max(1,NA), if TRANA = 'T' or 'C'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,kb) +C where kb is NB when TRANB = 'N', and is MB otherwise. +C If TRANB = 'N', the leading MB-by-NB part of this array +C must contain the matrix B; otherwise, the leading NB-by-MB +C part of this array must contain the matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= max(1,MB), if TRANB = 'N'; +C LDB >= max(1,NB), if TRANB = 'T' or 'C'. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) +C On entry, if beta is nonzero, the leading MC-by-NC part of +C this array must contain the given matric C, where +C MC = MA*MB and NC = NA*NB. +C On exit, the leading MC-by-NC part of this array contains +C the computed matrix expression +C C = alpha*kron( op(A), op(B) ) + beta*C. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= max(1,MC). +C +C MC (output) INTEGER +C The number of rows of the matrix C. MC = MA*MB. +C +C NC (output) INTEGER +C The number of columns of the matrix C. NC = NA*NB. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Kronecker product of the matrices op(A) and op(B) is computed +C column by column. +C +C FURTHER COMMENTS +C +C The multiplications by zero elements in A are avoided, if the +C matrix A is considered to be sparse, i.e., if +C (number of zeros in A)/(MA*NA) >= SPARST = 0.8. The code makes +C NB+1 passes through the matrix A, and MA*NA passes through the +C matrix B. If LDA and/or LDB are very large, and op(A) = A' and/or +C op(B) = B', it could be more efficient to transpose A and/or B +C before calling this routine, and use the 'N' values for TRANA +C and/or TRANB. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, February 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + DOUBLE PRECISION SPARST + PARAMETER ( SPARST = 0.8D0 ) +C .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER INFO, LDA, LDB, LDC, MA, MB, MC, NA, NB, NC + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) +C .. Local Scalars .. + LOGICAL SPARSE, TRANSA, TRANSB + INTEGER I, IC, J, JC, K, L, LC, NZ + DOUBLE PRECISION AIJ +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLASET, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + TRANSA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) + TRANSB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) + MC = MA*MB + INFO = 0 + IF( .NOT.( TRANSA .OR. LSAME( TRANA, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( TRANSB .OR. LSAME( TRANB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( MA.LT.0 ) THEN + INFO = -3 + ELSE IF( NA.LT.0 ) THEN + INFO = -4 + ELSE IF( MB.LT.0 ) THEN + INFO = -5 + ELSE IF( NB.LT.0 ) THEN + INFO = -6 + ELSE IF( ( TRANSA .AND. LDA.LT.NA ) .OR. LDA.LT.1 .OR. + $ ( .NOT.TRANSA .AND. LDA.LT.MA ) ) THEN + INFO = -10 + ELSE IF( ( TRANSB .AND. LDB.LT.NB ) .OR. LDB.LT.1 .OR. + $ ( .NOT.TRANSB .AND. LDB.LT.MB ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, MC ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01VD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + NC = NA*NB + IF ( MC.EQ.0 .OR. NC.EQ.0 ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) THEN + IF ( BETA.EQ.ZERO ) THEN + CALL DLASET( 'Full', MC, NC, ZERO, ZERO, C, LDC ) + ELSE IF ( BETA.NE.ONE ) THEN +C + DO 10 J = 1, NC + CALL DSCAL( MC, BETA, C(1,J), 1 ) + 10 CONTINUE +C + END IF + RETURN + END IF +C + DUM(1) = ZERO + JC = 1 + NZ = 0 +C +C Compute the Kronecker product of the matrices op(A) and op(B), +C C = alpha*kron( op(A), op(B) ) + beta*C. +C First, check if A is sparse. Here, A is considered as being sparse +C if (number of zeros in A)/(MA*NA) >= SPARST. +C + DO 30 J = 1, NA +C + DO 20 I = 1, MA + IF ( TRANSA ) THEN + IF ( A(J,I).EQ.ZERO ) + $ NZ = NZ + 1 + ELSE + IF ( A(I,J).EQ.ZERO ) + $ NZ = NZ + 1 + END IF + 20 CONTINUE +C + 30 CONTINUE +C + SPARSE = DBLE( NZ )/DBLE( MA*NA ).GE.SPARST +C + IF ( .NOT.TRANSA .AND. .NOT.TRANSB ) THEN +C +C Case op(A) = A and op(B) = B. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 80 J = 1, NA +C + DO 70 K = 1, NB + IC = 1 +C + DO 60 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 50 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 50 CONTINUE +C + END IF + IC = IC + MB + 60 CONTINUE +C + JC = JC + 1 + 70 CONTINUE +C + 80 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 120 J = 1, NA +C + DO 110 K = 1, NB + IC = 1 +C + DO 100 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 90 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 90 CONTINUE +C + IC = IC + MB + 100 CONTINUE +C + JC = JC + 1 + 110 CONTINUE +C + 120 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 160 J = 1, NA +C + DO 150 K = 1, NB + IC = 1 +C + DO 140 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 130 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 130 CONTINUE +C + END IF + IC = IC + MB + 140 CONTINUE +C + JC = JC + 1 + 150 CONTINUE +C + 160 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 200 J = 1, NA +C + DO 190 K = 1, NB + IC = 1 +C + DO 180 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 170 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 170 CONTINUE +C + IC = IC + MB + 180 CONTINUE +C + JC = JC + 1 + 190 CONTINUE +C + 200 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 240 J = 1, NA +C + DO 230 K = 1, NB + IC = 1 +C + DO 220 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 210 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 210 CONTINUE +C + END IF + IC = IC + MB + 220 CONTINUE +C + JC = JC + 1 + 230 CONTINUE +C + 240 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 280 J = 1, NA +C + DO 270 K = 1, NB + IC = 1 +C + DO 260 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 250 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 250 CONTINUE +C + IC = IC + MB + 260 CONTINUE +C + JC = JC + 1 + 270 CONTINUE +C + 280 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 320 J = 1, NA +C + DO 310 K = 1, NB + IC = 1 +C + DO 300 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 290 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 290 CONTINUE +C + END IF + IC = IC + MB + 300 CONTINUE +C + JC = JC + 1 + 310 CONTINUE +C + 320 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 360 J = 1, NA +C + DO 350 K = 1, NB + IC = 1 +C + DO 340 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 330 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 330 CONTINUE +C + IC = IC + MB + 340 CONTINUE +C + JC = JC + 1 + 350 CONTINUE +C + 360 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 400 J = 1, NA +C + DO 390 K = 1, NB + IC = 1 +C + DO 380 I = 1, MA + AIJ = A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 370 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 370 CONTINUE +C + END IF + IC = IC + MB + 380 CONTINUE +C + JC = JC + 1 + 390 CONTINUE +C + 400 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 440 J = 1, NA +C + DO 430 K = 1, NB + IC = 1 +C + DO 420 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 410 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 410 CONTINUE +C + IC = IC + MB + 420 CONTINUE +C + JC = JC + 1 + 430 CONTINUE +C + 440 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 480 J = 1, NA +C + DO 470 K = 1, NB + IC = 1 +C + DO 460 I = 1, MA + AIJ = ALPHA*A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 450 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 450 CONTINUE +C + END IF + IC = IC + MB + 460 CONTINUE +C + JC = JC + 1 + 470 CONTINUE +C + 480 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 520 J = 1, NA +C + DO 510 K = 1, NB + IC = 1 +C + DO 500 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 490 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 490 CONTINUE +C + IC = IC + MB + 500 CONTINUE +C + JC = JC + 1 + 510 CONTINUE +C + 520 CONTINUE +C + END IF + END IF + END IF + ELSE IF ( TRANSA .AND. .NOT.TRANSB ) THEN +C +C Case op(A) = A' and op(B) = B. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 560 J = 1, NA +C + DO 550 K = 1, NB + IC = 1 +C + DO 540 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 530 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 530 CONTINUE +C + END IF + IC = IC + MB + 540 CONTINUE +C + JC = JC + 1 + 550 CONTINUE +C + 560 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 600 J = 1, NA +C + DO 590 K = 1, NB + IC = 1 +C + DO 580 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 570 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 570 CONTINUE +C + IC = IC + MB + 580 CONTINUE +C + JC = JC + 1 + 590 CONTINUE +C + 600 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 640 J = 1, NA +C + DO 630 K = 1, NB + IC = 1 +C + DO 620 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 610 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 610 CONTINUE +C + END IF + IC = IC + MB + 620 CONTINUE +C + JC = JC + 1 + 630 CONTINUE +C + 640 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 680 J = 1, NA +C + DO 670 K = 1, NB + IC = 1 +C + DO 660 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 650 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 650 CONTINUE +C + IC = IC + MB + 660 CONTINUE +C + JC = JC + 1 + 670 CONTINUE +C + 680 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 720 J = 1, NA +C + DO 710 K = 1, NB + IC = 1 +C + DO 700 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 690 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 690 CONTINUE +C + END IF + IC = IC + MB + 700 CONTINUE +C + JC = JC + 1 + 710 CONTINUE +C + 720 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 760 J = 1, NA +C + DO 750 K = 1, NB + IC = 1 +C + DO 740 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 730 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 730 CONTINUE +C + IC = IC + MB + 740 CONTINUE +C + JC = JC + 1 + 750 CONTINUE +C + 760 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 800 J = 1, NA +C + DO 790 K = 1, NB + IC = 1 +C + DO 780 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 770 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 770 CONTINUE +C + END IF + IC = IC + MB + 780 CONTINUE +C + JC = JC + 1 + 790 CONTINUE +C + 800 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 840 J = 1, NA +C + DO 830 K = 1, NB + IC = 1 +C + DO 820 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 810 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 810 CONTINUE +C + IC = IC + MB + 820 CONTINUE +C + JC = JC + 1 + 830 CONTINUE +C + 840 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 880 J = 1, NA +C + DO 870 K = 1, NB + IC = 1 +C + DO 860 I = 1, MA + AIJ = A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 850 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 850 CONTINUE +C + END IF + IC = IC + MB + 860 CONTINUE +C + JC = JC + 1 + 870 CONTINUE +C + 880 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 920 J = 1, NA +C + DO 910 K = 1, NB + IC = 1 +C + DO 900 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 890 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 890 CONTINUE +C + IC = IC + MB + 900 CONTINUE +C + JC = JC + 1 + 910 CONTINUE +C + 920 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 960 J = 1, NA +C + DO 950 K = 1, NB + IC = 1 +C + DO 940 I = 1, MA + AIJ = ALPHA*A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 930 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 930 CONTINUE +C + END IF + IC = IC + MB + 940 CONTINUE +C + JC = JC + 1 + 950 CONTINUE +C + 960 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 1000 J = 1, NA +C + DO 990 K = 1, NB + IC = 1 +C + DO 980 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 970 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 970 CONTINUE +C + IC = IC + MB + 980 CONTINUE +C + JC = JC + 1 + 990 CONTINUE +C + 1000 CONTINUE +C + END IF + END IF + END IF + ELSE IF ( TRANSB .AND. .NOT.TRANSA ) THEN +C +C Case op(A) = A and op(B) = B'. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 1080 J = 1, NA +C + DO 1070 K = 1, NB + IC = 1 +C + DO 1060 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1050 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1050 CONTINUE +C + END IF + IC = IC + MB + 1060 CONTINUE +C + JC = JC + 1 + 1070 CONTINUE +C + 1080 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 1120 J = 1, NA +C + DO 1110 K = 1, NB + IC = 1 +C + DO 1100 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 1090 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1090 CONTINUE +C + IC = IC + MB + 1100 CONTINUE +C + JC = JC + 1 + 1110 CONTINUE +C + 1120 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 1160 J = 1, NA +C + DO 1150 K = 1, NB + IC = 1 +C + DO 1140 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1130 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1130 CONTINUE +C + END IF + IC = IC + MB + 1140 CONTINUE +C + JC = JC + 1 + 1150 CONTINUE +C + 1160 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 1200 J = 1, NA +C + DO 1190 K = 1, NB + IC = 1 +C + DO 1180 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 1170 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1170 CONTINUE +C + IC = IC + MB + 1180 CONTINUE +C + JC = JC + 1 + 1190 CONTINUE +C + 1200 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 1240 J = 1, NA +C + DO 1230 K = 1, NB + IC = 1 +C + DO 1220 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1210 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1210 CONTINUE +C + END IF + IC = IC + MB + 1220 CONTINUE +C + JC = JC + 1 + 1230 CONTINUE +C + 1240 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 1280 J = 1, NA +C + DO 1270 K = 1, NB + IC = 1 +C + DO 1260 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 1250 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1250 CONTINUE +C + IC = IC + MB + 1260 CONTINUE +C + JC = JC + 1 + 1270 CONTINUE +C + 1280 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 1320 J = 1, NA +C + DO 1310 K = 1, NB + IC = 1 +C + DO 1300 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1290 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1290 CONTINUE +C + END IF + IC = IC + MB + 1300 CONTINUE +C + JC = JC + 1 + 1310 CONTINUE +C + 1320 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 1360 J = 1, NA +C + DO 1350 K = 1, NB + IC = 1 +C + DO 1340 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 1330 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1330 CONTINUE +C + IC = IC + MB + 1340 CONTINUE +C + JC = JC + 1 + 1350 CONTINUE +C + 1360 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 1400 J = 1, NA +C + DO 1390 K = 1, NB + IC = 1 +C + DO 1380 I = 1, MA + AIJ = A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1370 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1370 CONTINUE +C + END IF + IC = IC + MB + 1380 CONTINUE +C + JC = JC + 1 + 1390 CONTINUE +C + 1400 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 1440 J = 1, NA +C + DO 1430 K = 1, NB + IC = 1 +C + DO 1420 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 1410 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1410 CONTINUE +C + IC = IC + MB + 1420 CONTINUE +C + JC = JC + 1 + 1430 CONTINUE +C + 1440 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 1480 J = 1, NA +C + DO 1470 K = 1, NB + IC = 1 +C + DO 1460 I = 1, MA + AIJ = ALPHA*A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1450 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1450 CONTINUE +C + END IF + IC = IC + MB + 1460 CONTINUE +C + JC = JC + 1 + 1470 CONTINUE +C + 1480 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 1520 J = 1, NA +C + DO 1510 K = 1, NB + IC = 1 +C + DO 1500 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 1490 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1490 CONTINUE +C + IC = IC + MB + 1500 CONTINUE +C + JC = JC + 1 + 1510 CONTINUE +C + 1520 CONTINUE +C + END IF + END IF + END IF + ELSE +C +C Case op(A) = A' and op(B) = B'. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 1580 J = 1, NA +C + DO 1570 K = 1, NB + IC = 1 +C + DO 1560 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1550 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1550 CONTINUE +C + END IF + IC = IC + MB + 1560 CONTINUE +C + JC = JC + 1 + 1570 CONTINUE +C + 1580 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 1620 J = 1, NA +C + DO 1610 K = 1, NB + IC = 1 +C + DO 1600 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 1590 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1590 CONTINUE +C + IC = IC + MB + 1600 CONTINUE +C + JC = JC + 1 + 1610 CONTINUE +C + 1620 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 1660 J = 1, NA +C + DO 1650 K = 1, NB + IC = 1 +C + DO 1640 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1630 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1630 CONTINUE +C + END IF + IC = IC + MB + 1640 CONTINUE +C + JC = JC + 1 + 1650 CONTINUE +C + 1660 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 1700 J = 1, NA +C + DO 1690 K = 1, NB + IC = 1 +C + DO 1680 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 1670 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1670 CONTINUE +C + IC = IC + MB + 1680 CONTINUE +C + JC = JC + 1 + 1690 CONTINUE +C + 1700 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 1740 J = 1, NA +C + DO 1730 K = 1, NB + IC = 1 +C + DO 1720 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1710 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1710 CONTINUE +C + END IF + IC = IC + MB + 1720 CONTINUE +C + JC = JC + 1 + 1730 CONTINUE +C + 1740 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 1780 J = 1, NA +C + DO 1770 K = 1, NB + IC = 1 +C + DO 1760 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 1750 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1750 CONTINUE +C + IC = IC + MB + 1760 CONTINUE +C + JC = JC + 1 + 1770 CONTINUE +C + 1780 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 1820 J = 1, NA +C + DO 1810 K = 1, NB + IC = 1 +C + DO 1800 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1790 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1790 CONTINUE +C + END IF + IC = IC + MB + 1800 CONTINUE +C + JC = JC + 1 + 1810 CONTINUE +C + 1820 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 1860 J = 1, NA +C + DO 1850 K = 1, NB + IC = 1 +C + DO 1840 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 1830 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1830 CONTINUE +C + IC = IC + MB + 1840 CONTINUE +C + JC = JC + 1 + 1850 CONTINUE +C + 1860 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 1900 J = 1, NA +C + DO 1890 K = 1, NB + IC = 1 +C + DO 1880 I = 1, MA + AIJ = A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1870 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1870 CONTINUE +C + END IF + IC = IC + MB + 1880 CONTINUE +C + JC = JC + 1 + 1890 CONTINUE +C + 1900 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 1940 J = 1, NA +C + DO 1930 K = 1, NB + IC = 1 +C + DO 1920 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 1910 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1910 CONTINUE +C + IC = IC + MB + 1920 CONTINUE +C + JC = JC + 1 + 1930 CONTINUE +C + 1940 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 1980 J = 1, NA +C + DO 1970 K = 1, NB + IC = 1 +C + DO 1960 I = 1, MA + AIJ = ALPHA*A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1950 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1950 CONTINUE +C + END IF + IC = IC + MB + 1960 CONTINUE +C + JC = JC + 1 + 1970 CONTINUE +C + 1980 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 2020 J = 1, NA +C + DO 2010 K = 1, NB + IC = 1 +C + DO 2000 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 1990 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1990 CONTINUE +C + IC = IC + MB + 2000 CONTINUE +C + JC = JC + 1 + 2010 CONTINUE +C + 2020 CONTINUE +C + END IF + END IF + END IF + END IF + RETURN +C *** Last line of MB01VD *** + END diff --git a/modules/cacsd/src/slicot/mb01vd.lo b/modules/cacsd/src/slicot/mb01vd.lo new file mode 100755 index 000000000..addb129ae --- /dev/null +++ b/modules/cacsd/src/slicot/mb01vd.lo @@ -0,0 +1,12 @@ +# src/slicot/mb01vd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb01vd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb02pd.f b/modules/cacsd/src/slicot/mb02pd.f new file mode 100755 index 000000000..b2b8db940 --- /dev/null +++ b/modules/cacsd/src/slicot/mb02pd.f @@ -0,0 +1,537 @@ + 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 RELEASE 3.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve (if well-conditioned) the matrix equations +C +C op( A )*X = B, +C +C where X and B are N-by-NRHS matrices, A is an N-by-N matrix and +C op( A ) is one of +C +C op( A ) = A or op( A ) = A'. +C +C Error bounds on the solution and a condition estimate are also +C provided. +C +C ARGUMENTS +C +C Mode Parameters +C +C FACT CHARACTER*1 +C Specifies whether or not the factored form of the matrix A +C is supplied on entry, and if not, whether the matrix A +C should be equilibrated before it is factored. +C = 'F': On entry, AF and IPIV contain the factored form +C of A. If EQUED is not 'N', the matrix A has been +C equilibrated with scaling factors given by R +C and C. A, AF, and IPIV are not modified. +C = 'N': The matrix A will be copied to AF and factored. +C = 'E': The matrix A will be equilibrated if necessary, +C then copied to AF and factored. +C +C TRANS CHARACTER*1 +C Specifies the form of the system of equations as follows: +C = 'N': A * X = B (No transpose); +C = 'T': A**T * X = B (Transpose); +C = 'C': A**H * X = B (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of linear equations, i.e., the order of the +C matrix A. N >= 0. +C +C NRHS (input) INTEGER +C The number of right hand sides, i.e., the number of +C columns of the matrices B and X. NRHS >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F' and EQUED is not 'N', +C then A must have been equilibrated by the scaling factors +C in R and/or C. A is not modified if FACT = 'F' or 'N', +C or if FACT = 'E' and EQUED = 'N' on exit. +C On exit, if EQUED .NE. 'N', the leading N-by-N part of +C this array contains the matrix A scaled as follows: +C EQUED = 'R': A := diag(R) * A; +C EQUED = 'C': A := A * diag(C); +C EQUED = 'B': A := diag(R) * A * diag(C). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C AF (input or output) DOUBLE PRECISION array, dimension +C (LDAF,N) +C If FACT = 'F', then AF is an input argument and on entry +C the leading N-by-N part of this array must contain the +C factors L and U from the factorization A = P*L*U as +C computed by DGETRF. If EQUED .NE. 'N', then AF is the +C factored form of the equilibrated matrix A. +C If FACT = 'N', then AF is an output argument and on exit +C the leading N-by-N part of this array contains the factors +C L and U from the factorization A = P*L*U of the original +C matrix A. +C If FACT = 'E', then AF is an output argument and on exit +C the leading N-by-N part of this array contains the factors +C L and U from the factorization A = P*L*U of the +C equilibrated matrix A (see the description of A for the +C form of the equilibrated matrix). +C +C LDAF (input) INTEGER +C The leading dimension of the array AF. LDAF >= max(1,N). +C +C IPIV (input or output) INTEGER array, dimension (N) +C If FACT = 'F', then IPIV is an input argument and on entry +C it must contain the pivot indices from the factorization +C A = P*L*U as computed by DGETRF; row i of the matrix was +C interchanged with row IPIV(i). +C If FACT = 'N', then IPIV is an output argument and on exit +C it contains the pivot indices from the factorization +C A = P*L*U of the original matrix A. +C If FACT = 'E', then IPIV is an output argument and on exit +C it contains the pivot indices from the factorization +C A = P*L*U of the equilibrated matrix A. +C +C EQUED (input or output) CHARACTER*1 +C Specifies the form of equilibration that was done as +C follows: +C = 'N': No equilibration (always true if FACT = 'N'); +C = 'R': Row equilibration, i.e., A has been premultiplied +C by diag(R); +C = 'C': Column equilibration, i.e., A has been +C postmultiplied by diag(C); +C = 'B': Both row and column equilibration, i.e., A has +C been replaced by diag(R) * A * diag(C). +C EQUED is an input argument if FACT = 'F'; otherwise, it is +C an output argument. +C +C R (input or output) DOUBLE PRECISION array, dimension (N) +C The row scale factors for A. If EQUED = 'R' or 'B', A is +C multiplied on the left by diag(R); if EQUED = 'N' or 'C', +C R is not accessed. R is an input argument if FACT = 'F'; +C otherwise, R is an output argument. If FACT = 'F' and +C EQUED = 'R' or 'B', each element of R must be positive. +C +C C (input or output) DOUBLE PRECISION array, dimension (N) +C The column scale factors for A. If EQUED = 'C' or 'B', +C A is multiplied on the right by diag(C); if EQUED = 'N' +C or 'R', C is not accessed. C is an input argument if +C FACT = 'F'; otherwise, C is an output argument. If +C FACT = 'F' and EQUED = 'C' or 'B', each element of C must +C be positive. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,NRHS) +C On entry, the leading N-by-NRHS part of this array must +C contain the right-hand side matrix B. +C On exit, +C if EQUED = 'N', B is not modified; +C if TRANS = 'N' and EQUED = 'R' or 'B', the leading +C N-by-NRHS part of this array contains diag(R)*B; +C if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', the leading +C N-by-NRHS part of this array contains diag(C)*B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) +C If INFO = 0 or INFO = N+1, the leading N-by-NRHS part of +C this array contains the solution matrix X to the original +C system of equations. Note that A and B are modified on +C exit if EQUED .NE. 'N', and the solution to the +C equilibrated system is inv(diag(C))*X if TRANS = 'N' and +C EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or +C 'C' and EQUED = 'R' or 'B'. +C +C LDX (input) INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C RCOND (output) DOUBLE PRECISION +C The estimate of the reciprocal condition number of the +C matrix A after equilibration (if done). If RCOND is less +C than the machine precision (in particular, if RCOND = 0), +C the matrix is singular to working precision. This +C condition is indicated by a return code of INFO > 0. +C For efficiency reasons, RCOND is computed only when the +C matrix A is factored, i.e., for FACT = 'N' or 'E'. For +C FACT = 'F', RCOND is not used, but it is assumed that it +C has been computed and checked before the routine call. +C +C FERR (output) DOUBLE PRECISION array, dimension (NRHS) +C The estimated forward error bound for each solution vector +C X(j) (the j-th column of the solution matrix X). +C If XTRUE is the true solution corresponding to X(j), +C FERR(j) is an estimated upper bound for the magnitude of +C the largest element in (X(j) - XTRUE) divided by the +C magnitude of the largest element in X(j). The estimate +C is as reliable as the estimate for RCOND, and is almost +C always a slight overestimate of the true error. +C +C BERR (output) DOUBLE PRECISION array, dimension (NRHS) +C The componentwise relative backward error of each solution +C vector X(j) (i.e., the smallest relative change in +C any element of A or B that makes X(j) an exact solution). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (4*N) +C On exit, DWORK(1) contains the reciprocal pivot growth +C factor norm(A)/norm(U). The "max absolute element" norm is +C used. If DWORK(1) is much less than 1, then the stability +C of the LU factorization of the (equilibrated) matrix A +C could be poor. This also means that the solution X, +C condition estimator RCOND, and forward error bound FERR +C could be unreliable. If factorization fails with +C 0 < INFO <= N, then DWORK(1) contains the reciprocal pivot +C growth factor for the leading INFO columns of A. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, and i is +C <= N: U(i,i) is exactly zero. The factorization +C has been completed, but the factor U is +C exactly singular, so the solution and error +C bounds could not be computed. RCOND = 0 is +C returned. +C = N+1: U is nonsingular, but RCOND is less than +C machine precision, meaning that the matrix is +C singular to working precision. Nevertheless, +C the solution and error bounds are computed +C because there are a number of situations +C where the computed solution can be more +C accurate than the value of RCOND would +C suggest. +C The positive values for INFO are set only when the +C matrix A is factored, i.e., for FACT = 'N' or 'E'. +C +C METHOD +C +C The following steps are performed: +C +C 1. If FACT = 'E', real scaling factors are computed to equilibrate +C the system: +C +C TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +C TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +C TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +C +C Whether or not the system will be equilibrated depends on the +C scaling of the matrix A, but if equilibration is used, A is +C overwritten by diag(R)*A*diag(C) and B by diag(R)*B +C (if TRANS='N') or diag(C)*B (if TRANS = 'T' or 'C'). +C +C 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +C the matrix A (after equilibration if FACT = 'E') as +C A = P * L * U, +C where P is a permutation matrix, L is a unit lower triangular +C matrix, and U is upper triangular. +C +C 3. If some U(i,i)=0, so that U is exactly singular, then the +C routine returns with INFO = i. Otherwise, the factored form +C of A is used to estimate the condition number of the matrix A. +C If the reciprocal of the condition number is less than machine +C precision, INFO = N+1 is returned as a warning, but the routine +C still goes on to solve for X and compute error bounds as +C described below. +C +C 4. The system of equations is solved for X using the factored form +C of A. +C +C 5. Iterative refinement is applied to improve the computed +C solution matrix and calculate error bounds and backward error +C estimates for it. +C +C 6. If equilibration was used, the matrix X is premultiplied by +C diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +C that it solves the original system before equilibration. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., Sorensen, D. +C LAPACK Users' Guide: Second Edition, SIAM, Philadelphia, 1995. +C +C FURTHER COMMENTS +C +C This is a simplified version of the LAPACK Library routine DGESVX, +C useful when several sets of matrix equations with the same +C coefficient matrix A and/or A' should be solved. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Condition number, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS + DOUBLE PRECISION RCOND +C .. +C .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ BERR( * ), C( * ), DWORK( * ), FERR( * ), + $ R( * ), X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + CHARACTER NORM + INTEGER I, INFEQU, J + DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, RPVGRW, SMLNUM +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLANTR + EXTERNAL LSAME, DLAMCH, DLANGE, DLANTR +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY, + $ DLAQGE, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Save Statement .. + SAVE RPVGRW +C .. +C .. Executable Statements .. +C + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + END IF +C +C Test the input parameters. +C + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) + $ THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -10 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -11 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -12 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02PD', -INFO ) + RETURN + END IF +C + IF( EQUIL ) THEN +C +C Compute row and column scalings to equilibrate the matrix A. +C + CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +C +C Equilibrate the matrix. +C + CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF + END IF +C +C Scale the right hand side. +C + IF( NOTRAN ) THEN + IF( ROWEQU ) THEN + DO 40 J = 1, NRHS + DO 30 I = 1, N + B( I, J ) = R( I )*B( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE IF( COLEQU ) THEN + DO 60 J = 1, NRHS + DO 50 I = 1, N + B( I, J ) = C( I )*B( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +C + IF( NOFACT .OR. EQUIL ) THEN +C +C Compute the LU factorization of A. +C + CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) + CALL DGETRF( N, N, AF, LDAF, IPIV, INFO ) +C +C Return if INFO is non-zero. +C + IF( INFO.NE.0 ) THEN + IF( INFO.GT.0 ) THEN +C +C Compute the reciprocal pivot growth factor of the +C leading rank-deficient INFO columns of A. +C + RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF, + $ DWORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = DLANGE( 'M', N, INFO, A, LDA, DWORK ) / + $ RPVGRW + END IF + DWORK( 1 ) = RPVGRW + RCOND = ZERO + END IF + RETURN + END IF +C +C Compute the norm of the matrix A and the +C reciprocal pivot growth factor RPVGRW. +C + IF( NOTRAN ) THEN + NORM = '1' + ELSE + NORM = 'I' + END IF + ANORM = DLANGE( NORM, N, N, A, LDA, DWORK ) + RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, DWORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = DLANGE( 'M', N, N, A, LDA, DWORK ) / RPVGRW + END IF +C +C Compute the reciprocal of the condition number of A. +C + CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, DWORK, IWORK, + $ INFO ) +C +C Set INFO = N+1 if the matrix is singular to working precision. +C + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 + END IF +C +C Compute the solution matrix X. +C + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +C +C Use iterative refinement to improve the computed solution and +C compute error bounds and backward error estimates for it. +C + CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, + $ LDX, FERR, BERR, DWORK, IWORK, INFO ) +C +C Transform the solution matrix X to a solution of the original +C system. +C + IF( NOTRAN ) THEN + IF( COLEQU ) THEN + DO 80 J = 1, NRHS + DO 70 I = 1, N + X( I, J ) = C( I )*X( I, J ) + 70 CONTINUE + 80 CONTINUE + DO 90 J = 1, NRHS + FERR( J ) = FERR( J ) / COLCND + 90 CONTINUE + END IF + ELSE IF( ROWEQU ) THEN + DO 110 J = 1, NRHS + DO 100 I = 1, N + X( I, J ) = R( I )*X( I, J ) + 100 CONTINUE + 110 CONTINUE + DO 120 J = 1, NRHS + FERR( J ) = FERR( J ) / ROWCND + 120 CONTINUE + END IF +C + DWORK( 1 ) = RPVGRW + RETURN +C +C *** Last line of MB02PD *** + END diff --git a/modules/cacsd/src/slicot/mb02pd.lo b/modules/cacsd/src/slicot/mb02pd.lo new file mode 100755 index 000000000..30d0822ef --- /dev/null +++ b/modules/cacsd/src/slicot/mb02pd.lo @@ -0,0 +1,12 @@ +# src/slicot/mb02pd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb02pd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb02qy.f b/modules/cacsd/src/slicot/mb02qy.f new file mode 100755 index 000000000..f8ad1df91 --- /dev/null +++ b/modules/cacsd/src/slicot/mb02qy.f @@ -0,0 +1,323 @@ + SUBROUTINE MB02QY( M, N, NRHS, RANK, A, LDA, JPVT, B, LDB, TAU, + $ DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To determine the minimum-norm solution to a real linear least +C squares problem: +C +C minimize || A * X - B ||, +C +C using the rank-revealing QR factorization of a real general +C M-by-N matrix A, computed by SLICOT Library routine MB03OD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices A and B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C NRHS (input) INTEGER +C The number of columns of the matrix B. NRHS >= 0. +C +C RANK (input) INTEGER +C The effective rank of A, as returned by SLICOT Library +C routine MB03OD. min(M,N) >= RANK >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry, the leading min(M,N)-by-N upper trapezoidal +C part of this array contains the triangular factor R, as +C returned by SLICOT Library routine MB03OD. The strict +C lower trapezoidal part of A is not referenced. +C On exit, if RANK < N, the leading RANK-by-RANK upper +C triangular part of this array contains the upper +C triangular matrix R of the complete orthogonal +C factorization of A, and the submatrix (1:RANK,RANK+1:N) +C of this array, with the array TAU, represent the +C orthogonal matrix Z (of the complete orthogonal +C factorization of A), as a product of RANK elementary +C reflectors. +C On exit, if RANK = N, this array is unchanged. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C JPVT (input) INTEGER array, dimension ( N ) +C The recorded permutations performed by SLICOT Library +C routine MB03OD; if JPVT(i) = k, then the i-th column +C of A*P was the k-th column of the original matrix A. +C +C B (input/output) DOUBLE PRECISION array, dimension +C ( LDB, NRHS ) +C On entry, if NRHS > 0, the leading M-by-NRHS part of +C this array must contain the matrix B (corresponding to +C the transformed matrix A, returned by SLICOT Library +C routine MB03OD). +C On exit, if NRHS > 0, the leading N-by-NRHS part of this +C array contains the solution matrix X. +C If M >= N and RANK = N, the residual sum-of-squares +C for the solution in the i-th column is given by the sum +C of squares of elements N+1:M in that column. +C If NRHS = 0, the array B is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= max(1,M,N), if NRHS > 0. +C LDB >= 1, if NRHS = 0. +C +C TAU (output) DOUBLE PRECISION array, dimension ( min(M,N) ) +C The scalar factors of the elementary reflectors. +C If RANK = N, the array TAU is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 1, N, NRHS ). +C For good performance, LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses a QR factorization with column pivoting: +C +C A * P = Q * R = Q * [ R11 R12 ], +C [ 0 R22 ] +C +C where R11 is an upper triangular submatrix of estimated rank +C RANK, the effective rank of A. The submatrix R22 can be +C considered as negligible. +C +C If RANK < N, then R12 is annihilated by orthogonal +C transformations from the right, arriving at the complete +C orthogonal factorization: +C +C A * P = Q * [ T11 0 ] * Z. +C [ 0 0 ] +C +C The minimum-norm solution is then +C +C X = P * Z' [ inv(T11)*Q1'*B ], +C [ 0 ] +C +C where Q1 consists of the first RANK columns of Q. +C +C The input data for MB02QY are the transformed matrices Q' * A +C (returned by SLICOT Library routine MB03OD) and Q' * B. +C Matrix Q is not needed. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Least squares solutions; QR decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), TAU( * ) +C .. Local Scalars .. + INTEGER I, IASCL, IBSCL, J, MN + DOUBLE PRECISION ANRM, BIGNUM, BNRM, MAXWRK, SMLNUM +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANTR + EXTERNAL DLAMCH, DLANGE, DLANTR +C .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLASCL, DLASET, DORMRZ, DTRSM, + $ DTZRZF, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C + MN = MIN( M, N ) +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( RANK.LT.0 .OR. RANK.GT.MN ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.1 .OR. ( NRHS.GT.0 .AND. LDB.LT.MAX( M, N ) ) ) + $ THEN + INFO = -9 + ELSE IF( LDWORK.LT.MAX( 1, N, NRHS ) ) THEN + INFO = -12 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02QY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( MN, NRHS ).EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C +C Logically partition R = [ R11 R12 ], +C [ 0 R22 ] +C +C where R11 = R(1:RANK,1:RANK). If RANK = N, let T11 = R11. +C + MAXWRK = DBLE( N ) + IF( RANK.LT.N ) THEN +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANTR( 'MaxNorm', 'Upper', 'Non-unit', RANK, N, A, LDA, + $ DWORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, RANK, N, A, LDA, + $ INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, RANK, N, A, LDA, + $ INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +C +C Matrix all zero. Return zero solution. +C + CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, B, LDB ) + DWORK( 1 ) = ONE + RETURN + END IF +C + BNRM = DLANGE( 'MaxNorm', M, NRHS, B, LDB, DWORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL DLASCL( 'General', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, + $ INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL DLASCL( 'General', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, + $ INFO ) + IBSCL = 2 + END IF +C +C [R11,R12] = [ T11, 0 ] * Z. +C Details of Householder rotations are stored in TAU. +C Workspace need RANK, prefer RANK*NB. +C + CALL DTZRZF( RANK, N, A, LDA, TAU, DWORK, LDWORK, INFO ) + MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) + END IF +C +C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). +C + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, + $ NRHS, ONE, A, LDA, B, LDB ) +C + IF( RANK.LT.N ) THEN +C + CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, B( RANK+1, 1 ), + $ LDB ) +C +C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). +C Workspace need NRHS, prefer NRHS*NB. +C + CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, + $ LDA, TAU, B, LDB, DWORK, LDWORK, INFO ) + MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) +C +C Undo scaling. +C + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'General', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, + $ INFO ) + CALL DLASCL( 'Upper', 0, 0, SMLNUM, ANRM, RANK, RANK, A, + $ LDA, INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'General', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, + $ INFO ) + CALL DLASCL( 'Upper', 0, 0, BIGNUM, ANRM, RANK, RANK, A, + $ LDA, INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'General', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, + $ INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'General', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, + $ INFO ) + END IF + END IF +C +C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). +C Workspace N. +C + DO 20 J = 1, NRHS +C + DO 10 I = 1, N + DWORK( JPVT( I ) ) = B( I, J ) + 10 CONTINUE +C + CALL DCOPY( N, DWORK, 1, B( 1, J ), 1 ) + 20 CONTINUE +C + DWORK( 1 ) = MAXWRK + RETURN +C +C *** Last line of MB02QY *** + END diff --git a/modules/cacsd/src/slicot/mb02qy.lo b/modules/cacsd/src/slicot/mb02qy.lo new file mode 100755 index 000000000..df4d53b47 --- /dev/null +++ b/modules/cacsd/src/slicot/mb02qy.lo @@ -0,0 +1,12 @@ +# src/slicot/mb02qy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb02qy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb02ud.f b/modules/cacsd/src/slicot/mb02ud.f new file mode 100755 index 000000000..9b069386a --- /dev/null +++ b/modules/cacsd/src/slicot/mb02ud.f @@ -0,0 +1,608 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To compute the minimum norm least squares solution of one of the +C following linear systems +C +C op(R)*X = alpha*B, (1) +C X*op(R) = alpha*B, (2) +C +C where alpha is a real scalar, op(R) is either R or its transpose, +C R', R is an L-by-L real upper triangular matrix, B is an M-by-N +C real matrix, and L = M for (1), or L = N for (2). Singular value +C decomposition, R = Q*S*P', is used, assuming that R is rank +C deficient. +C +C ARGUMENTS +C +C Mode Parameters +C +C FACT CHARACTER*1 +C Specifies whether R has been previously factored or not, +C as follows: +C = 'F': R has been factored and its rank and singular +C value decomposition, R = Q*S*P', are available; +C = 'N': R has not been factored and its singular value +C decomposition, R = Q*S*P', should be computed. +C +C SIDE CHARACTER*1 +C Specifies whether op(R) appears on the left or right +C of X as follows: +C = 'L': Solve op(R)*X = alpha*B (op(R) is on the left); +C = 'R': Solve X*op(R) = alpha*B (op(R) is on the right). +C +C TRANS CHARACTER*1 +C Specifies the form of op(R) to be used as follows: +C = 'N': op(R) = R; +C = 'T': op(R) = R'; +C = 'C': op(R) = R'. +C +C JOBP CHARACTER*1 +C Specifies whether or not the pseudoinverse of R is to be +C computed or it is available as follows: +C = 'P': Compute pinv(R), if FACT = 'N', or +C use pinv(R), if FACT = 'F'; +C = 'N': Do not compute or use pinv(R). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix B. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then B need not be +C set before entry. +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of R. +C Singular values of R satisfying Sv(i) <= RCOND*Sv(1) are +C treated as zero. If RCOND <= 0, then EPS is used instead, +C where EPS is the relative machine precision (see LAPACK +C Library routine DLAMCH). RCOND <= 1. +C RCOND is not used if FACT = 'F'. +C +C RANK (input or output) INTEGER +C The rank of matrix R. +C RANK is an input parameter when FACT = 'F', and an output +C parameter when FACT = 'N'. L >= RANK >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) +C On entry, if FACT = 'F', the leading L-by-L part of this +C array must contain the L-by-L orthogonal matrix P' from +C singular value decomposition, R = Q*S*P', of the matrix R; +C if JOBP = 'P', the first RANK rows of P' are assumed to be +C scaled by inv(S(1:RANK,1:RANK)). +C On entry, if FACT = 'N', the leading L-by-L upper +C triangular part of this array must contain the upper +C triangular matrix R. +C On exit, if INFO = 0, the leading L-by-L part of this +C array contains the L-by-L orthogonal matrix P', with its +C first RANK rows scaled by inv(S(1:RANK,1:RANK)), when +C JOBP = 'P'. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,L). +C +C Q (input or output) DOUBLE PRECISION array, dimension +C (LDQ,L) +C On entry, if FACT = 'F', the leading L-by-L part of this +C array must contain the L-by-L orthogonal matrix Q from +C singular value decomposition, R = Q*S*P', of the matrix R. +C If FACT = 'N', this array need not be set on entry, and +C on exit, if INFO = 0, the leading L-by-L part of this +C array contains the orthogonal matrix Q. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,L). +C +C SV (input or output) DOUBLE PRECISION array, dimension (L) +C On entry, if FACT = 'F', the first RANK entries of this +C array must contain the reciprocal of the largest RANK +C singular values of the matrix R, and the last L-RANK +C entries of this array must contain the remaining singular +C values of R sorted in descending order. +C If FACT = 'N', this array need not be set on input, and +C on exit, if INFO = 0, the first RANK entries of this array +C contain the reciprocal of the largest RANK singular values +C of the matrix R, and the last L-RANK entries of this array +C contain the remaining singular values of R sorted in +C descending order. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, if ALPHA <> 0, the leading M-by-N part of this +C array must contain the matrix B. +C On exit, if INFO = 0 and RANK > 0, the leading M-by-N part +C of this array contains the M-by-N solution matrix X. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C RP (input or output) DOUBLE PRECISION array, dimension +C (LDRP,L) +C On entry, if FACT = 'F', JOBP = 'P', and RANK > 0, the +C leading L-by-L part of this array must contain the L-by-L +C matrix pinv(R), the Moore-Penrose pseudoinverse of R. +C On exit, if FACT = 'N', JOBP = 'P', and RANK > 0, the +C leading L-by-L part of this array contains the L-by-L +C matrix pinv(R), the Moore-Penrose pseudoinverse of R. +C If JOBP = 'N', this array is not referenced. +C +C LDRP INTEGER +C The leading dimension of array RP. +C LDRP >= MAX(1,L), if JOBP = 'P'. +C LDRP >= 1, if JOBP = 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; +C if INFO = i, 1 <= i <= L, then DWORK(2:L) contain the +C unconverged superdiagonal elements of an upper bidiagonal +C matrix D whose diagonal is in SV (not necessarily sorted). +C D satisfies R = Q*D*P', so it has the same singular +C values as R, and singular vectors related by Q and P'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,L), if FACT = 'F'; +C LDWORK >= MAX(1,5*L), if FACT = 'N'. +C For optimum performance LDWORK should be larger than +C MAX(1,L,M*N), if FACT = 'F'; +C MAX(1,5*L,M*N), if FACT = 'N'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i = 1:L, the SVD algorithm has failed +C to converge. In this case INFO specifies how many +C superdiagonals did not converge (see the description +C of DWORK); this failure is not likely to occur. +C +C METHOD +C +C The L-by-L upper triangular matrix R is factored as R = Q*S*P', +C if FACT = 'N', using SLICOT Library routine MB03UD, where Q and P +C are L-by-L orthogonal matrices and S is an L-by-L diagonal matrix +C with non-negative diagonal elements, SV(1), SV(2), ..., SV(L), +C ordered decreasingly. Then, the effective rank of R is estimated, +C and matrix (or matrix-vector) products and scalings are used to +C compute X. If FACT = 'F', only matrix (or matrix-vector) products +C and scalings are performed. +C +C FURTHER COMMENTS +C +C Option JOBP = 'P' should be used only if the pseudoinverse is +C really needed. Usually, it is possible to avoid the use of +C pseudoinverse, by computing least squares solutions. +C The routine uses BLAS 3 calculations if LDWORK >= M*N, and BLAS 2 +C calculations, otherwise. No advantage of any additional workspace +C larger than L is taken for matrix products, but the routine can +C be called repeatedly for chunks of columns of B, if LDWORK < M*N. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute of Informatics, Bucharest, Oct. 1999. +C +C REVISIONS +C +C V. Sima, Feb. 2000. +C +C KEYWORDS +C +C Bidiagonalization, orthogonal transformation, singular value +C decomposition, singular values, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER FACT, JOBP, SIDE, TRANS + INTEGER INFO, LDB, LDQ, LDR, LDRP, LDWORK, M, N, RANK + DOUBLE PRECISION ALPHA, RCOND +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), DWORK(*), Q(LDQ,*), R(LDR,*), + $ RP(LDRP,*), SV(*) +C .. Local Scalars .. + LOGICAL LEFT, NFCT, PINV, TRAN + CHARACTER*1 NTRAN + INTEGER I, L, MAXWRK, MINWRK, MN + DOUBLE PRECISION TOLL +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, DLASET, MB01SD, + $ MB03UD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + INFO = 0 + NFCT = LSAME( FACT, 'N' ) + LEFT = LSAME( SIDE, 'L' ) + PINV = LSAME( JOBP, 'P' ) + TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + IF( LEFT ) THEN + L = M + ELSE + L = N + END IF + MN = M*N + IF( .NOT.NFCT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -3 + ELSE IF( .NOT.PINV .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( NFCT .AND. RCOND.GT.ONE ) THEN + INFO = -8 + ELSE IF( .NOT.NFCT .AND. ( RANK.LT.ZERO .OR. RANK.GT.L ) ) THEN + INFO = -9 + ELSE IF( LDR.LT.MAX( 1, L ) ) THEN + INFO = -11 + ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDRP.LT.1 .OR. ( PINV .AND. LDRP.LT.L ) ) THEN + INFO = -18 + END IF +C +C Compute workspace +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately following +C subroutine, as returned by ILAENV.) +C + MINWRK = 1 + IF( INFO.EQ.0 .AND. LDWORK.GE.1 .AND. L.GT.0 ) THEN + MINWRK = MAX( 1, L ) + MAXWRK = MAX( MINWRK, MN ) + IF( NFCT ) THEN + MAXWRK = MAX( MAXWRK, 3*L+2*L* + $ ILAENV( 1, 'DGEBRD', ' ', L, L, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*L+L* + $ ILAENV( 1, 'DORGBR', 'Q', L, L, L, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*L+L* + $ ILAENV( 1, 'DORGBR', 'P', L, L, L, -1 ) ) + MINWRK = MAX( 1, 5*L ) + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -20 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02UD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( L.EQ.0 ) THEN + IF( NFCT ) + $ RANK = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( NFCT ) THEN +C +C Compute the SVD of R, R = Q*S*P'. +C Matrix Q is computed in the array Q, and P' overwrites R. +C Workspace: need 5*L; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', L, R, LDR, Q, LDQ, SV, + $ DWORK, LDWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN +C +C Use the default tolerance, if required. +C + TOLL = RCOND + IF( TOLL.LE.ZERO ) + $ TOLL = DLAMCH( 'Precision' ) + TOLL = MAX( TOLL*SV(1), DLAMCH( 'Safe minimum' ) ) +C +C Estimate the rank of R. +C + DO 10 I = 1, L + IF ( TOLL.GT.SV(I) ) + $ GO TO 20 + 10 CONTINUE +C + I = L + 1 + 20 CONTINUE + RANK = I - 1 +C + DO 30 I = 1, RANK + SV(I) = ONE / SV(I) + 30 CONTINUE +C + IF( PINV .AND. RANK.GT.0 ) THEN +C +C Compute pinv(S)'*P' in R. +C + CALL MB01SD( 'Row scaling', RANK, L, R, LDR, SV, SV ) +C +C Compute pinv(R) = P*pinv(S)*Q' in RP. +C + CALL DGEMM( 'Transpose', 'Transpose', L, L, RANK, ONE, R, + $ LDR, Q, LDQ, ZERO, RP, LDRP ) + END IF + END IF +C +C Return if min(M,N) = 0 or RANK = 0. +C + IF( MIN( M, N ).EQ.0 .OR. RANK.EQ.0 ) THEN + DWORK(1) = MAXWRK + RETURN + END IF +C +C Set X = 0 if alpha = 0. +C + IF( ALPHA.EQ.ZERO ) THEN + CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) + DWORK(1) = MAXWRK + RETURN + END IF +C + IF( PINV ) THEN +C + IF( LEFT ) THEN +C +C Compute alpha*op(pinv(R))*B in workspace and save it in B. +C Workspace: need M (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + CALL DGEMM( TRANS, 'NoTranspose', M, N, M, ALPHA, + $ RP, LDRP, B, LDB, ZERO, DWORK, M ) + CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) + ELSE +C + DO 40 I = 1, N + CALL DGEMV( TRANS, M, M, ALPHA, RP, LDRP, B(1,I), 1, + $ ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 40 CONTINUE +C + END IF + ELSE +C +C Compute alpha*B*op(pinv(R)) in workspace and save it in B. +C Workspace: need N (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + CALL DGEMM( 'NoTranspose', TRANS, M, N, N, ALPHA, B, LDB, + $ RP, LDRP, ZERO, DWORK, M ) + CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) + ELSE +C + IF( TRAN ) THEN + NTRAN = 'N' + ELSE + NTRAN = 'T' + END IF +C + DO 50 I = 1, M + CALL DGEMV( NTRAN, N, N, ALPHA, RP, LDRP, B(I,1), LDB, + $ ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 50 CONTINUE +C + END IF + END IF +C + ELSE +C + IF( LEFT ) THEN +C +C Compute alpha*P*pinv(S)*Q'*B or alpha*Q*pinv(S)'*P'*B. +C Workspace: need M (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + IF( TRAN ) THEN +C +C Compute alpha*P'*B in workspace. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, + $ ALPHA, R, LDR, B, LDB, ZERO, DWORK, M ) +C +C Compute alpha*pinv(S)'*P'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, + $ SV ) +C +C Compute alpha*Q*pinv(S)'*P'*B. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, + $ ONE, Q, LDQ, DWORK, M, ZERO, B, LDB ) + ELSE +C +C Compute alpha*Q'*B in workspace. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, + $ ALPHA, Q, LDQ, B, LDB, ZERO, DWORK, M ) +C +C Compute alpha*pinv(S)*Q'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, + $ SV ) +C +C Compute alpha*P*pinv(S)*Q'*B. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, RANK, + $ ONE, R, LDR, DWORK, M, ZERO, B, LDB ) + END IF + ELSE + IF( TRAN ) THEN +C +C Compute alpha*P'*B in B using workspace. +C + DO 60 I = 1, N + CALL DGEMV( 'NoTranspose', M, M, ALPHA, R, LDR, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 60 CONTINUE +C +C Compute alpha*pinv(S)'*P'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) +C +C Compute alpha*Q*pinv(S)'*P'*B in B using workspace. +C + DO 70 I = 1, N + CALL DGEMV( 'NoTranspose', M, RANK, ONE, Q, LDQ, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 70 CONTINUE + ELSE +C +C Compute alpha*Q'*B in B using workspace. +C + DO 80 I = 1, N + CALL DGEMV( 'Transpose', M, M, ALPHA, Q, LDQ, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 80 CONTINUE +C +C Compute alpha*pinv(S)*Q'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) +C +C Compute alpha*P*pinv(S)*Q'*B in B using workspace. +C + DO 90 I = 1, N + CALL DGEMV( 'Transpose', RANK, M, ONE, R, LDR, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 90 CONTINUE + END IF + END IF + ELSE +C +C Compute alpha*B*P*pinv(S)*Q' or alpha*B*Q*pinv(S)'*P'. +C Workspace: need N (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + IF( TRAN ) THEN +C +C Compute alpha*B*Q in workspace. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, + $ ALPHA, B, LDB, Q, LDQ, ZERO, DWORK, M ) +C +C Compute alpha*B*Q*pinv(S)'. +C + CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, + $ SV ) +C +C Compute alpha*B*Q*pinv(S)'*P' in B. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, + $ ONE, DWORK, M, R, LDR, ZERO, B, LDB ) + ELSE +C +C Compute alpha*B*P in workspace. +C + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, + $ ALPHA, B, LDB, R, LDR, ZERO, DWORK, M ) +C +C Compute alpha*B*P*pinv(S). +C + CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, + $ SV ) +C +C Compute alpha*B*P*pinv(S)*Q' in B. +C + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, RANK, + $ ONE, DWORK, M, Q, LDQ, ZERO, B, LDB ) + END IF + ELSE + IF( TRAN ) THEN +C +C Compute alpha*B*Q in B using workspace. +C + DO 100 I = 1, M + CALL DGEMV( 'Transpose', N, N, ALPHA, Q, LDQ, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 100 CONTINUE +C +C Compute alpha*B*Q*pinv(S)'. +C + CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, + $ SV ) +C +C Compute alpha*B*Q*pinv(S)'*P' in B using workspace. +C + DO 110 I = 1, M + CALL DGEMV( 'Transpose', RANK, N, ONE, R, LDR, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 110 CONTINUE +C + ELSE +C +C Compute alpha*B*P in B using workspace. +C + DO 120 I = 1, M + CALL DGEMV( 'NoTranspose', N, N, ALPHA, R, LDR, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 120 CONTINUE +C +C Compute alpha*B*P*pinv(S). +C + CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, + $ SV ) +C +C Compute alpha*B*P*pinv(S)*Q' in B using workspace. +C + DO 130 I = 1, M + CALL DGEMV( 'NoTranspose', N, RANK, ONE, Q, LDQ, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 130 CONTINUE + END IF + END IF + END IF + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK(1) = MAXWRK +C + RETURN +C *** Last line of MB02UD *** + END diff --git a/modules/cacsd/src/slicot/mb02ud.lo b/modules/cacsd/src/slicot/mb02ud.lo new file mode 100755 index 000000000..38c7cfd9a --- /dev/null +++ b/modules/cacsd/src/slicot/mb02ud.lo @@ -0,0 +1,12 @@ +# src/slicot/mb02ud.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb02ud.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb03od.f b/modules/cacsd/src/slicot/mb03od.f new file mode 100755 index 000000000..e5d7caba5 --- /dev/null +++ b/modules/cacsd/src/slicot/mb03od.f @@ -0,0 +1,264 @@ + SUBROUTINE MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, + $ RANK, SVAL, DWORK, INFO ) +C +C RELEASE 3.0, WGS COPYRIGHT 1997. +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 where LDWORK = max( 1, 3*N ), if JOBQR = 'Q'; +C LDWORK = max( 1, 2*min( M, N ) ), if JOBQR = '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 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 ****************************************************************** +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*1 JOBQR + 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 LJOBQR + INTEGER I, ISMAX, ISMIN, MN + DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEQPF, DLAIC1, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. +C .. Executable Statements .. +C + LJOBQR = LSAME( JOBQR, 'Q' ) + MN = MIN( M, N ) + ISMIN = 1 + ISMAX = MN + 1 +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 + 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 + RETURN + END IF +C + IF ( LJOBQR ) THEN +C +C Compute QR factorization with column pivoting of A: +C A * P = Q * R +C Workspace 3*N. Details of Householder rotations stored in TAU. +C + CALL DGEQPF( M, N, A, LDA, JPVT, TAU, DWORK( 1 ), INFO ) + 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 + RETURN +C *** Last line of MB03OD *** + END diff --git a/modules/cacsd/src/slicot/mb03od.lo b/modules/cacsd/src/slicot/mb03od.lo new file mode 100755 index 000000000..ff0b2dcbb --- /dev/null +++ b/modules/cacsd/src/slicot/mb03od.lo @@ -0,0 +1,12 @@ +# src/slicot/mb03od.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb03od.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb03oy.f b/modules/cacsd/src/slicot/mb03oy.f new file mode 100755 index 000000000..47ee9a60c --- /dev/null +++ b/modules/cacsd/src/slicot/mb03oy.f @@ -0,0 +1,373 @@ + SUBROUTINE MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 ( LDWORK ) +C where LDWORK = max( 1, 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 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 - +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 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2, IDAMAX +C .. External Subroutines .. + EXTERNAL DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03OY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + MN = MIN( M, N ) + IF( MN.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + ISMIN = 1 + ISMAX = ISMIN + N +C +C Initialize partial column norms and pivoting vector. The first n +C elements of DWORK store the exact column norms. The already used +C leading part is then overwritten by the condition estimator. +C + DO 10 I = 1, N + DWORK( I ) = DNRM2( M, A( 1, I ), 1 ) + DWORK( N+I ) = DWORK( I ) + JPVT( I ) = I + 10 CONTINUE +C +C Compute factorization and determine RANK using incremental +C condition estimation. +C + RANK = 0 +C + 20 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 +C +C Determine ith pivot column and swap if necessary. +C + PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 ) +C + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + DWORK( PVT ) = DWORK( I ) + DWORK( N+PVT ) = DWORK( N+I ) + END IF +C +C Save A(I,I) and generate elementary reflector H(i). +C + IF( I.LT.M ) THEN + AII = A( I, I ) + CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) + ELSE + TAU( M ) = ZERO + END IF +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( A( 1, 1 ) ) + IF ( SMAX.EQ.ZERO ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = ONE + C2 = ONE + ELSE +C +C One step of incremental condition estimation. +C + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) + END IF +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Continue factorization, as rank is at least RANK. +C + IF( I.LT.N ) THEN +C +C Apply H(i) to A(i:m,i+1:n) from the left. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ TAU( I ), A( I, I+1 ), LDA, + $ DWORK( 2*N+1 ) ) + A( I, I ) = AII + END IF +C +C Update partial column norms. +C + DO 30 J = I + 1, N + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - + $ ( ABS( A( I, J ) ) / DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + 0.05D0*TEMP* + $ ( DWORK( J ) / DWORK( N+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + IF( M-I.GT.0 ) THEN + DWORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) + DWORK( N+J ) = DWORK( J ) + ELSE + DWORK( J ) = ZERO + DWORK( N+J ) = ZERO + END IF + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + DO 40 I = 1, RANK + DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) + DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) + 40 CONTINUE +C + DWORK( ISMIN+RANK ) = C1 + DWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 20 + END IF + END IF + END IF + END IF +C +C Restore the changed part of the (RANK+1)-th column and set SVAL. +C + IF ( RANK.LT.N ) THEN + IF ( I.LT.M ) THEN + CALL DSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = AII + END IF + END IF + IF ( RANK.EQ.0 ) THEN + SMIN = ZERO + SMINPR = ZERO + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR +C + RETURN +C *** Last line of MB03OY *** + END diff --git a/modules/cacsd/src/slicot/mb03oy.lo b/modules/cacsd/src/slicot/mb03oy.lo new file mode 100755 index 000000000..1aed446c4 --- /dev/null +++ b/modules/cacsd/src/slicot/mb03oy.lo @@ -0,0 +1,12 @@ +# src/slicot/mb03oy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb03oy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb03ud.f b/modules/cacsd/src/slicot/mb03ud.f new file mode 100755 index 000000000..cce1ecf6a --- /dev/null +++ b/modules/cacsd/src/slicot/mb03ud.f @@ -0,0 +1,302 @@ + SUBROUTINE MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK, + $ LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To compute all, or part, of the singular value decomposition of a +C real upper triangular matrix. +C +C The N-by-N upper triangular matrix A is factored as A = Q*S*P', +C where Q and P are N-by-N orthogonal matrices and S is an +C N-by-N diagonal matrix with non-negative diagonal elements, +C SV(1), SV(2), ..., SV(N), ordered such that +C +C SV(1) >= SV(2) >= ... >= SV(N) >= 0. +C +C The columns of Q are the left singular vectors of A, the diagonal +C elements of S are the singular values of A and the columns of P +C are the right singular vectors of A. +C +C Either or both of Q and P' may be requested. +C When P' is computed, it is returned in A. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBQ CHARACTER*1 +C Specifies whether the user wishes to compute the matrix Q +C of left singular vectors as follows: +C = 'V': Left singular vectors are computed; +C = 'N': No left singular vectors are computed. +C +C JOBP CHARACTER*1 +C Specifies whether the user wishes to compute the matrix P' +C of right singular vectors as follows: +C = 'V': Right singular vectors are computed; +C = 'N': No right singular vectors are computed. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix A. +C On exit, if JOBP = 'V', the leading N-by-N part of this +C array contains the N-by-N orthogonal matrix P'; otherwise +C the N-by-N upper triangular part of A is used as internal +C workspace. The strictly lower triangular part of A is set +C internally to zero before the reduction to bidiagonal form +C is performed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C If JOBQ = 'V', the leading N-by-N part of this array +C contains the orthogonal matrix Q. +C If JOBQ = 'N', Q is not referenced. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, and when JOBQ = 'V', LDQ >= MAX(1,N). +C +C SV (output) DOUBLE PRECISION array, dimension (N) +C The N singular values of the matrix A, sorted in +C descending order. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; +C if INFO > 0, DWORK(2:N) contains the unconverged +C superdiagonal elements of an upper bidiagonal matrix B +C whose diagonal is in SV (not necessarily sorted). +C B satisfies A = Q*B*P', so it has the same singular +C values as A, and singular vectors related by Q and P'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,5*N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: the QR algorithm has failed to converge. In this +C case INFO specifies how many superdiagonals did not +C converge (see the description of DWORK). +C This failure is not likely to occur. +C +C METHOD +C +C The routine reduces A to bidiagonal form by means of elementary +C reflectors and then uses the QR algorithm on the bidiagonal form. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute of Informatics, Bucharest, and +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C March 1998. Based on the RASP routine DTRSVD. +C +C REVISIONS +C +C V. Sima, Feb. 2000. +C +C KEYWORDS +C +C Bidiagonalization, orthogonal transformation, singular value +C decomposition, singular values, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBP, JOBQ + INTEGER INFO, LDA, LDQ, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), Q(LDQ,*), SV(*) +C .. Local Scalars .. + LOGICAL WANTQ, WANTP + INTEGER I, IE, ISCL, ITAUP, ITAUQ, JWORK, MAXWRK, + $ MINWRK, NCOLP, NCOLQ + DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANTR + EXTERNAL DLAMCH, DLANTR, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DBDSQR, DGEBRD, DLACPY, DLASCL, DLASET, DORGBR, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + INFO = 0 + WANTQ = LSAME( JOBQ, 'V' ) + WANTP = LSAME( JOBP, 'V' ) + MINWRK = 1 + IF( .NOT.WANTQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.WANTP .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.WANTQ .AND. LDQ.LT.1 ) ) THEN + INFO = -7 + END IF +C +C Compute workspace +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately following +C subroutine, as returned by ILAENV.) +C + IF( INFO.EQ.0 .AND. LDWORK.GE.1 .AND. N.GT.0 ) THEN + MAXWRK = 3*N+2*N*ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) + IF( WANTQ ) + $ MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + IF( WANTP ) + $ MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) + MINWRK = 5*N + MAXWRK = MAX( MAXWRK, MINWRK ) + DWORK(1) = MAXWRK + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03UD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Get machine constants. +C + EPS = DLAMCH( 'P' ) + SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS + BIGNUM = ONE / SMLNUM +C +C Scale A if max entry outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANTR( 'Max', 'Upper', 'Non-unit', N, N, A, LDA, DUM ) + ISCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ISCL = 1 + CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, N, N, A, LDA, INFO ) + ELSE IF( ANRM.GT.BIGNUM ) THEN + ISCL = 1 + CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, N, N, A, LDA, INFO ) + END IF +C +C Zero out below. +C + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, A(2,1), LDA ) +C +C Find the singular values and optionally the singular vectors +C of the upper triangular matrix A. +C + IE = 1 + ITAUQ = IE + N + ITAUP = ITAUQ + N + JWORK = ITAUP + N +C +C First reduce the matrix to bidiagonal form. The diagonal +C elements will be in SV and the superdiagonals in DWORK(IE). +C (Workspace: need 4*N, prefer 3*N+2*N*NB) +C + CALL DGEBRD( N, N, A, LDA, SV, DWORK(IE), DWORK(ITAUQ), + $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) + IF( WANTQ ) THEN +C +C Generate the transformation matrix Q corresponding to the +C left singular vectors. +C (Workspace: need 4*N, prefer 3*N+N*NB) +C + NCOLQ = N + CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) + CALL DORGBR( 'Q', N, N, N, Q, LDQ, DWORK(ITAUQ), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + ELSE + NCOLQ = 0 + END IF + IF( WANTP ) THEN +C +C Generate the transformation matrix P' corresponding to the +C right singular vectors. +C (Workspace: need 4*N, prefer 3*N+N*NB) +C + NCOLP = N + CALL DORGBR( 'P', N, N, N, A, LDA, DWORK(ITAUP), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + ELSE + NCOLP = 0 + END IF + JWORK = IE + N +C +C Perform bidiagonal QR iteration, to obtain all or part of the +C singular value decomposition of A. +C (Workspace: need 5*N) +C + CALL DBDSQR( 'U', N, NCOLP, NCOLQ, 0, SV, DWORK(IE), A, LDA, + $ Q, LDQ, DUM, 1, DWORK(JWORK), INFO ) +C +C If DBDSQR failed to converge, copy unconverged superdiagonals +C to DWORK(2:N). +C + IF( INFO.NE.0 ) THEN + DO 10 I = N - 1, 1, -1 + DWORK(I+1) = DWORK(I+IE-1) + 10 CONTINUE + END IF +C +C Undo scaling if necessary. +C + IF( ISCL.EQ.1 ) THEN + IF( ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N, 1, SV, N, INFO ) + IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N-1, 1, DWORK(2), N, + $ INFO ) + IF( ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N, 1, SV, N, INFO ) + IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N-1, 1, DWORK(2), N, + $ INFO ) + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK(1) = MAXWRK +C + RETURN +C *** Last line of MB03UD *** + END diff --git a/modules/cacsd/src/slicot/mb03ud.lo b/modules/cacsd/src/slicot/mb03ud.lo new file mode 100755 index 000000000..d9d1f72b6 --- /dev/null +++ b/modules/cacsd/src/slicot/mb03ud.lo @@ -0,0 +1,12 @@ +# src/slicot/mb03ud.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb03ud.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb04id.f b/modules/cacsd/src/slicot/mb04id.f new file mode 100755 index 000000000..f6b5004e9 --- /dev/null +++ b/modules/cacsd/src/slicot/mb04id.f @@ -0,0 +1,235 @@ + SUBROUTINE MB04ID( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, + $ INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 Error Indicator +C +C INFO INTEGER +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 - +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 .. + INTEGER I + DOUBLE PRECISION FIRST, WRKOPT +C .. External Subroutines .. + EXTERNAL DGEQRF, DLARF, DLARFG, DORMQR, 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( ( L.EQ.0 .AND. LDB.LT.1 ) .OR. + $ ( L.GT.0 .AND. LDB.LT.MAX( 1, N ) ) ) THEN + INFO = -8 + ELSE IF( LDWORK.LT.MAX( 1, M - 1, M - P, L ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04ID', -INFO ) + 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( ONE, DBLE( M - 1 ), DBLE( 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, 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, DWORK(1) ) + END IF + END IF +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of MB04ID *** + END diff --git a/modules/cacsd/src/slicot/mb04id.lo b/modules/cacsd/src/slicot/mb04id.lo new file mode 100755 index 000000000..1c7d9fdc4 --- /dev/null +++ b/modules/cacsd/src/slicot/mb04id.lo @@ -0,0 +1,12 @@ +# src/slicot/mb04id.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb04id.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb04iy.f b/modules/cacsd/src/slicot/mb04iy.f new file mode 100755 index 000000000..2d0061fff --- /dev/null +++ b/modules/cacsd/src/slicot/mb04iy.f @@ -0,0 +1,311 @@ + SUBROUTINE MB04IY( SIDE, TRANS, N, M, K, P, A, LDA, TAU, C, LDC, + $ DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To overwrite the real n-by-m matrix C with Q' * C, Q * C, +C C * Q', or C * Q, according to the following table +C +C SIDE = 'L' SIDE = 'R' +C TRANS = 'N': Q * C C * Q +C TRANS = 'T': Q'* C C * Q' +C +C where Q is a real orthogonal matrix defined as the product of +C k elementary reflectors +C +C Q = H(1) H(2) . . . H(k) +C +C as returned by SLICOT Library routine MB04ID. Q is of order n +C if SIDE = 'L' and of order m if SIDE = 'R'. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specify if Q or Q' is applied from the left or right, +C as follows: +C = 'L': apply Q or Q' from the left; +C = 'R': apply Q or Q' from the right. +C +C TRANS CHARACTER*1 +C Specify if Q or Q' is to be applied, as follows: +C = 'N': apply Q (No transpose); +C = 'T': apply Q' (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrix C. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix C. M >= 0. +C +C K (input) INTEGER +C The number of elementary reflectors whose product defines +C the matrix Q. +C N >= K >= 0, if SIDE = 'L'; +C M >= K >= 0, if SIDE = 'R'. +C +C P (input) INTEGER +C The order of the zero triagle (or the number of rows of +C the zero trapezoid) in the matrix triangularized by SLICOT +C Library routine MB04ID. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,K) +C On input, the elements in the rows i+1:min(n,n-p-1+i) of +C the i-th column, and TAU(i), represent the orthogonal +C reflector H(i), so that matrix Q is the product of +C elementary reflectors: Q = H(1) H(2) . . . H(k). +C A is modified by the routine but restored on exit. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= max(1,N), if SIDE = 'L'; +C LDA >= max(1,M), if SIDE = 'R'. +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C The scalar factors of the elementary reflectors. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix C. +C On exit, the leading N-by-M part of this array contains +C the updated matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,M), if SIDE = 'L'; +C LDWORK >= MAX(1,N), if SIDE = 'R'. +C For optimum performance LDWORK >= M*NB if SIDE = 'L', +C or LDWORK >= N*NB if SIDE = 'R', where NB is the optimal +C block size. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If SIDE = 'L', each elementary reflector H(i) modifies +C n-p elements of each column of C, for i = 1:p+1, and +C n-i+1 elements, for i = p+2:k. +C If SIDE = 'R', each elementary reflector H(i) modifies +C m-p elements of each row of C, for i = 1:p+1, and +C m-i+1 elements, for i = p+2:k. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Matrix operations, QR decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, K, LDA, LDC, LDWORK, M, N, P + CHARACTER SIDE, TRANS +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), TAU( * ) +C .. Local Scalars .. + LOGICAL LEFT, TRAN + INTEGER I + DOUBLE PRECISION AII, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARF, DORMQR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C +C Check the scalar input arguments. +C + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + TRAN = LSAME( TRANS, 'T' ) +C + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. ( LEFT .AND. K.GT.N ) .OR. + $ ( .NOT.LEFT .AND. K.GT.M ) ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( ( LEFT .AND. LDA.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LEFT .AND. LDA.LT.MAX( 1, M ) ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( ( LEFT .AND. LDWORK.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LEFT .AND. LDWORK.LT.MAX( 1, N ) ) ) THEN + INFO = -13 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04IY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 .OR. ( LEFT .AND. N.LT.P ) + $ .OR. ( .NOT.LEFT .AND. M.LT.P ) ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF( LEFT ) THEN + WRKOPT = DBLE( M ) + IF( TRAN ) THEN +C + DO 10 I = 1, MIN( K, P ) +C +C Apply H(i) to C(i:i+n-p-1,1:m), from the left. +C Workspace: need M. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), + $ C( I, 1 ), LDC, DWORK ) + A( I, I ) = AII + 10 CONTINUE +C + IF ( P.LE.MIN( N, K ) ) THEN +C +C Apply H(i) to C, i = p+1:k, from the left. +C Workspace: need M; prefer M*NB. +C + CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + ELSE +C + IF ( P.LE.MIN( N, K ) ) THEN +C +C Apply H(i) to C, i = k:p+1:-1, from the left. +C Workspace: need M; prefer M*NB. +C + CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + DO 20 I = MIN( K, P ), 1, -1 +C +C Apply H(i) to C(i:i+n-p-1,1:m), from the left. +C Workspace: need M. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), + $ C( I, 1 ), LDC, DWORK ) + A( I, I ) = AII + 20 CONTINUE + END IF +C + ELSE +C + WRKOPT = DBLE( N ) + IF( TRAN ) THEN +C + IF ( P.LE.MIN( M, K ) ) THEN +C +C Apply H(i) to C, i = k:p+1:-1, from the right. +C Workspace: need N; prefer N*NB. +C + CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + DO 30 I = MIN( K, P ), 1, -1 +C +C Apply H(i) to C(1:n,i:i+m-p-1), from the right. +C Workspace: need N. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), + $ C( 1, I ), LDC, DWORK ) + A( I, I ) = AII + 30 CONTINUE +C + ELSE +C + DO 40 I = 1, MIN( K, P ) +C +C Apply H(i) to C(1:n,i:i+m-p-1), from the right. +C Workspace: need N. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), + $ C( 1, I ), LDC, DWORK ) + A( I, I ) = AII + 40 CONTINUE +C + IF ( P.LE.MIN( M, K ) ) THEN +C +C Apply H(i) to C, i = p+1:k, from the right. +C Workspace: need N; prefer N*NB. +C + CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + END IF + END IF +C + DWORK( 1 ) = WRKOPT + RETURN +C +C *** Last line of MB04IY *** + END diff --git a/modules/cacsd/src/slicot/mb04iy.lo b/modules/cacsd/src/slicot/mb04iy.lo new file mode 100755 index 000000000..ffa543ebb --- /dev/null +++ b/modules/cacsd/src/slicot/mb04iy.lo @@ -0,0 +1,12 @@ +# src/slicot/mb04iy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb04iy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb04kd.f b/modules/cacsd/src/slicot/mb04kd.f new file mode 100755 index 000000000..a6e402d94 --- /dev/null +++ b/modules/cacsd/src/slicot/mb04kd.f @@ -0,0 +1,193 @@ + SUBROUTINE MB04KD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C RELEASE 3.0, WGS COPYRIGHT 1997. +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*1 UPLO + INTEGER LDA, LDB, LDC, LDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ R(LDR,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C + IF( MIN( N, P ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'U' ) + IM = P +C + DO 10 I = 1, N +C +C Annihilate the I-th column of A and apply the transformations +C to the entire block matrix, exploiting its structure. +C + IF( LUPLO ) IM = MIN( I, P ) + CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C +C [ R(I,I+1:N) 0 ] +C [ w C(I,:) ] := [ 1 v' ] * [ ] +C [ A(1:IM,I+1:N) B(1:IM,:) ] +C + IF( I.LT.N ) THEN + CALL DCOPY( N-I, R(I,I+1), LDR, DWORK, 1 ) + CALL DGEMV( 'Transpose', IM, N-I, ONE, A(1,I+1), LDA, + $ A(1,I), 1, ONE, DWORK, 1 ) + END IF + CALL DGEMV( 'Transpose', IM, M, ONE, B, LDB, A(1,I), 1, + $ ZERO, C(I,1), LDC ) +C +C [ R(I,I+1:N) C(I,:) ] [ R(I,I+1:N) 0 ] +C [ ] := [ ] +C [ A(1:IM,I+1:N) D(1:IM,:) ] [ A(1:IM,I+1:N) B(1:IM,:) ] +C +C [ 1 ] +C - tau * [ ] * [ w C(I,:) ] +C [ v ] +C + IF( I.LT.N ) THEN + CALL DAXPY( N-I, -TAU(I), DWORK, 1, R(I,I+1), LDR ) + CALL DGER( IM, N-I, -TAU(I), A(1,I), 1, DWORK, 1, + $ A(1,I+1), LDA ) + END IF + CALL DSCAL( M, -TAU(I), C(I,1), LDC ) + CALL DGER( IM, M, ONE, A(1,I), 1, C(I,1), LDC, B, LDB ) + END IF + 10 CONTINUE +C + RETURN +C *** Last line of MB04KD *** + END diff --git a/modules/cacsd/src/slicot/mb04kd.lo b/modules/cacsd/src/slicot/mb04kd.lo new file mode 100755 index 000000000..01dc653e3 --- /dev/null +++ b/modules/cacsd/src/slicot/mb04kd.lo @@ -0,0 +1,12 @@ +# src/slicot/mb04kd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb04kd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb04nd.f b/modules/cacsd/src/slicot/mb04nd.f new file mode 100755 index 000000000..c087e99a7 --- /dev/null +++ b/modules/cacsd/src/slicot/mb04nd.f @@ -0,0 +1,241 @@ + SUBROUTINE MB04ND( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To calculate an RQ factorization of the first block row and +C apply the orthogonal transformations (from the right) also to the +C second block row of a structured matrix, as follows +C _ +C [ A R ] [ 0 R ] +C [ ] * Q' = [ _ _ ] +C [ C B ] [ C B ] +C _ +C where R and R are upper triangular. The matrix A can be full or +C upper trapezoidal/triangular. The problem structure is exploited. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates if the matrix A is or not triangular as follows: +C = 'U': Matrix A is upper trapezoidal/triangular; +C = 'F': Matrix A is full. +C +C Input/Output Parameters +C +C N (input) INTEGER _ +C The order of the matrices R and R. N >= 0. +C +C M (input) INTEGER +C The number of rows of the matrices B and C. M >= 0. +C +C P (input) INTEGER +C The number of columns of the matrices A and C. P >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the leading N-by-N upper triangular part of this +C _ +C array contains the upper triangular matrix R. +C The strict lower triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,P) +C On entry, if UPLO = 'F', the leading N-by-P part of this +C array must contain the matrix A. For UPLO = 'U', if +C N <= P, the upper triangle of the subarray A(1:N,P-N+1:P) +C must contain the N-by-N upper triangular matrix A, and if +C N >= P, the elements on and above the (N-P)-th subdiagonal +C must contain the N-by-P upper trapezoidal matrix A. +C On exit, if UPLO = 'F', the leading N-by-P part of this +C array contains the trailing components (the vectors v, see +C METHOD) of the elementary reflectors used in the +C factorization. If UPLO = 'U', the upper triangle of the +C subarray A(1:N,P-N+1:P) (if N <= P), or the elements on +C and above the (N-P)-th subdiagonal (if N >= P), contain +C the trailing components (the vectors v, see METHOD) of the +C elementary reflectors used in the factorization. +C The remaining elements are not referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C _ +C the computed matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) +C On entry, the leading M-by-P part of this array must +C contain the matrix C. +C On exit, the leading M-by-P part of this array contains +C _ +C the computed matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N-1,M)) +C +C METHOD +C +C The routine uses N Householder transformations exploiting the zero +C pattern of the block matrix. A Householder matrix has the form +C +C ( 1 ) +C H = I - tau *u *u', u = ( v ), +C i i i i i ( i) +C +C where v is a P-vector, if UPLO = 'F', or a min(N-i+1,P)-vector, +C i +C if UPLO = 'U'. The components of v are stored in the i-th row +C i +C of A, and tau is stored in TAU(i), i = N,N-1,...,1. +C i +C In-line code for applying Householder transformations is used +C whenever possible (see MB04NY routine). +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary reflector, RQ factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDC, LDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ R(LDR,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM, IP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, MB04NY +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + IF( MIN( N, P ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'U' ) + IF ( LUPLO ) THEN +C + DO 10 I = N, 1, -1 +C +C Annihilate the I-th row of A and apply the transformations +C to the entire block matrix, exploiting its structure. +C + IM = MIN( N-I+1, P ) + IP = MAX( P-N+I, 1 ) + CALL DLARFG( IM+1, R(I,I), A(I,IP), LDA, TAU(I) ) +C +C Compute +C [ 1 ] +C w := [ R(1:I-1,I) A(1:I-1,IP:P) ] * [ ], +C [ v ] +C +C [ R(1:I-1,I) A(1:I-1,IP:P) ] = +C [ R(1:I-1,I) A(1:I-1,IP:P) ] - tau * w * [ 1 v' ]. +C + IF ( I.GT.0 ) +C + $ CALL MB04NY( I-1, IM, A(I,IP), LDA, TAU(I), R(1,I), LDR, + $ A(1,IP), LDA, DWORK ) +C +C Compute +C [ 1 ] +C w := [ B(:,I) C(:,IP:P) ] * [ ], +C [ v ] +C +C [ B(:,I) C(:,IP:P) ] = [ B(:,I) C(:,IP:P) ] - +C tau * w * [ 1 v' ]. +C + IF ( M.GT.0 ) + $ CALL MB04NY( M, IM, A(I,IP), LDA, TAU(I), B(1,I), LDB, + $ C(1,IP), LDC, DWORK ) + 10 CONTINUE +C + ELSE +C + DO 20 I = N, 2 , -1 +C +C Annihilate the I-th row of A and apply the transformations +C to the first block row, exploiting its structure. +C + CALL DLARFG( P+1, R(I,I), A(I,1), LDA, TAU(I) ) +C +C Compute +C [ 1 ] +C w := [ R(1:I-1,I) A(1:I-1,:) ] * [ ], +C [ v ] +C +C [ R(1:I-1,I) A(1:I-1,:) ] = [ R(1:I-1,I) A(1:I-1,:) ] - +C tau * w * [ 1 v' ]. +C + CALL MB04NY( I-1, P, A(I,1), LDA, TAU(I), R(1,I), LDR, A, + $ LDA, DWORK ) + 20 CONTINUE +C + CALL DLARFG( P+1, R(1,1), A(1,1), LDA, TAU(1) ) + IF ( M.GT.0 ) THEN +C +C Apply the transformations to the second block row. +C + DO 30 I = N, 1, -1 +C +C Compute +C [ 1 ] +C w := [ B(:,I) C ] * [ ], +C [ v ] +C +C [ B(:,I) C ] = [ B(:,I) C ] - tau * w * [ 1 v' ]. +C + CALL MB04NY( M, P, A(I,1), LDA, TAU(I), B(1,I), LDB, C, + $ LDC, DWORK ) + 30 CONTINUE +C + END IF + END IF + RETURN +C *** Last line of MB04ND *** + END diff --git a/modules/cacsd/src/slicot/mb04nd.lo b/modules/cacsd/src/slicot/mb04nd.lo new file mode 100755 index 000000000..08ea5f9b5 --- /dev/null +++ b/modules/cacsd/src/slicot/mb04nd.lo @@ -0,0 +1,12 @@ +# src/slicot/mb04nd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb04nd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb04ny.f b/modules/cacsd/src/slicot/mb04ny.f new file mode 100755 index 000000000..211f536c8 --- /dev/null +++ b/modules/cacsd/src/slicot/mb04ny.f @@ -0,0 +1,421 @@ + SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To apply a real elementary reflector H to a real m-by-(n+1) +C matrix C = [ A B ], from the right, where A has one column. H is +C represented in the form +C ( 1 ) +C H = I - tau * u *u', u = ( ), +C ( v ) +C where tau is a real scalar and v is a real n-vector. +C +C If tau = 0, then H is taken to be the unit matrix. +C +C In-line code is used if H has order < 11. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices A and B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix B. N >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (1+(N-1)*ABS( INCV )) +C The vector v in the representation of H. +C +C INCV (input) INTEGER +C The increment between the elements of v. INCV <> 0. +C +C TAU (input) DOUBLE PRECISION +C The scalar factor of the elementary reflector H. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,1) +C On entry, the leading M-by-1 part of this array must +C contain the matrix A. +C On exit, the leading M-by-1 part of this array contains +C the updated matrix A (the first column of C * H). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C the updated matrix B (the last n columns of C * H). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (M) +C DWORK is not referenced if H has order less than 11. +C +C METHOD +C +C The routine applies the elementary reflector H, taking the special +C structure of C into account. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. +C Based on LAPACK routines DLARFX and DLATZM. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, elementary reflector, orthogonal +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INCV, LDA, LDB, M, N + DOUBLE PRECISION TAU +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) +C .. Local Scalars .. + INTEGER IV, J + DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, + $ V3, V4, V5, V6, V7, V8, V9 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +C +C .. Executable Statements .. +C + IF( TAU.EQ.ZERO ) + $ RETURN +C +C Form C * H, where H has order n+1. +C + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 ) N+1 +C +C Code for general N. Compute +C +C w := C*u, C := C - tau * w * u'. +C + CALL DCOPY( M, A, 1, DWORK, 1 ) + CALL DGEMV( 'No transpose', M, N, ONE, B, LDB, V, INCV, ONE, + $ DWORK, 1 ) + CALL DAXPY( M, -TAU, DWORK, 1, A, 1 ) + CALL DGER( M, N, -TAU, DWORK, 1, V, INCV, B, LDB ) + GO TO 210 + 10 CONTINUE +C +C Special code for 1 x 1 Householder +C + T1 = ONE - TAU + DO 20 J = 1, M + A( J, 1 ) = T1*A( J, 1 ) + 20 CONTINUE + GO TO 210 + 30 CONTINUE +C +C Special code for 2 x 2 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + DO 40 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + 40 CONTINUE + GO TO 210 + 50 CONTINUE +C +C Special code for 3 x 3 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + DO 60 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + 60 CONTINUE + GO TO 210 + 70 CONTINUE +C +C Special code for 4 x 4 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + DO 80 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + 80 CONTINUE + GO TO 210 + 90 CONTINUE +C +C Special code for 5 x 5 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + DO 100 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + 100 CONTINUE + GO TO 210 + 110 CONTINUE +C +C Special code for 6 x 6 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + DO 120 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + 120 CONTINUE + GO TO 210 + 130 CONTINUE +C +C Special code for 7 x 7 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + DO 140 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + 140 CONTINUE + GO TO 210 + 150 CONTINUE +C +C Special code for 8 x 8 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + IV = IV + INCV + V7 = V( IV ) + T7 = TAU*V7 + DO 160 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + + $ V7*B( J, 7 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + B( J, 7 ) = B( J, 7 ) - SUM*T7 + 160 CONTINUE + GO TO 210 + 170 CONTINUE +C +C Special code for 9 x 9 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + IV = IV + INCV + V7 = V( IV ) + T7 = TAU*V7 + IV = IV + INCV + V8 = V( IV ) + T8 = TAU*V8 + DO 180 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + + $ V7*B( J, 7 ) + V8*B( J, 8 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + B( J, 7 ) = B( J, 7 ) - SUM*T7 + B( J, 8 ) = B( J, 8 ) - SUM*T8 + 180 CONTINUE + GO TO 210 + 190 CONTINUE +C +C Special code for 10 x 10 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + IV = IV + INCV + V7 = V( IV ) + T7 = TAU*V7 + IV = IV + INCV + V8 = V( IV ) + T8 = TAU*V8 + IV = IV + INCV + V9 = V( IV ) + T9 = TAU*V9 + DO 200 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + + $ V7*B( J, 7 ) + V8*B( J, 8 ) + V9*B( J, 9 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + B( J, 7 ) = B( J, 7 ) - SUM*T7 + B( J, 8 ) = B( J, 8 ) - SUM*T8 + B( J, 9 ) = B( J, 9 ) - SUM*T9 + 200 CONTINUE + 210 CONTINUE + RETURN +C *** Last line of MB04NY *** + END diff --git a/modules/cacsd/src/slicot/mb04ny.lo b/modules/cacsd/src/slicot/mb04ny.lo new file mode 100755 index 000000000..e0d262481 --- /dev/null +++ b/modules/cacsd/src/slicot/mb04ny.lo @@ -0,0 +1,12 @@ +# src/slicot/mb04ny.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb04ny.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb04od.f b/modules/cacsd/src/slicot/mb04od.f new file mode 100755 index 000000000..eb4a3871a --- /dev/null +++ b/modules/cacsd/src/slicot/mb04od.f @@ -0,0 +1,241 @@ + SUBROUTINE MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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*1 UPLO + INTEGER LDA, LDB, LDC, LDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ R(LDR,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, MB04OY +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + IF( MIN( N, P ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'U' ) + IF ( LUPLO ) THEN +C + DO 10 I = 1, N +C +C Annihilate the I-th column of A and apply the +C transformations to the entire block matrix, exploiting +C its structure. +C + IM = MIN( I, P ) + CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) +C +C Compute +C [ R(I,I+1:N) ] +C w := [ 1 v' ] * [ ], +C [ A(1:IM,I+1:N) ] +C +C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w . +C [ A(1:IM,I+1:N) ] [ A(1:IM,I+1:N) ] [ v ] +C + IF ( N-I.GT.0 ) + $ CALL MB04OY( IM, N-I, A(1,I), TAU(I), R(I,I+1), LDR, + $ A(1,I+1), LDA, DWORK ) +C +C Compute +C [ B(I,:) ] +C w := [ 1 v' ] * [ ], +C [ C(1:IM,:) ] +C +C [ B(I,:) ] [ B(I,:) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w. +C [ C(1:IM,:) ] [ C(1:IM,:) ] [ v ] +C +C + IF ( M.GT.0 ) + $ CALL MB04OY( IM, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, + $ DWORK ) + 10 CONTINUE +C + ELSE +C + DO 20 I = 1, N - 1 +C +C Annihilate the I-th column of A and apply the +C transformations to the first block column, exploiting its +C structure. +C + CALL DLARFG( P+1, R(I,I), A(1,I), 1, TAU(I) ) +C +C Compute +C [ R(I,I+1:N) ] +C w := [ 1 v' ] * [ ], +C [ A(:,I+1:N) ] +C +C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w . +C [ A(:,I+1:N) ] [ A(:,I+1:N) ] [ v ] +C + CALL MB04OY( P, N-I, A(1,I), TAU(I), R(I,I+1), LDR, + $ A(1,I+1), LDA, DWORK ) + 20 CONTINUE +C + CALL DLARFG( P+1, R(N,N), A(1,N), 1, TAU(N) ) + IF ( M.GT.0 ) THEN +C +C Apply the transformations to the second block column. +C + DO 30 I = 1, N +C +C Compute +C [ B(I,:) ] +C w := [ 1 v' ] * [ ], +C [ C ] +C +C [ B(I,:) ] [ B(I,:) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w. +C [ C ] [ C ] [ v ] +C + CALL MB04OY( P, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, + $ DWORK ) + 30 CONTINUE +C + END IF + END IF + RETURN +C *** Last line of MB04OD *** + END diff --git a/modules/cacsd/src/slicot/mb04od.lo b/modules/cacsd/src/slicot/mb04od.lo new file mode 100755 index 000000000..b2ae7f140 --- /dev/null +++ b/modules/cacsd/src/slicot/mb04od.lo @@ -0,0 +1,12 @@ +# src/slicot/mb04od.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb04od.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/mb04oy.f b/modules/cacsd/src/slicot/mb04oy.f new file mode 100755 index 000000000..4c4b6a00a --- /dev/null +++ b/modules/cacsd/src/slicot/mb04oy.f @@ -0,0 +1,354 @@ + SUBROUTINE MB04OY( M, N, V, TAU, A, LDA, B, LDB, DWORK ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To apply a real elementary reflector H to a real (m+1)-by-n +C matrix C = [ A ], from the left, where A has one row. H is +C [ B ] +C represented in the form +C ( 1 ) +C H = I - tau * u *u', u = ( ), +C ( v ) +C where tau is a real scalar and v is a real m-vector. +C +C If tau = 0, then H is taken to be the unit matrix. +C +C In-line code is used if H has order < 11. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices A and B. N >= 0. +C +C V (input) DOUBLE PRECISION array, dimension (M) +C The vector v in the representation of H. +C +C TAU (input) DOUBLE PRECISION +C The scalar factor of the elementary reflector H. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading 1-by-N part of this array must +C contain the matrix A. +C On exit, the leading 1-by-N part of this array contains +C the updated matrix A (the first row of H * C). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= 1. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C the updated matrix B (the last m rows of H * C). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C DWORK is not referenced if H has order less than 11. +C +C METHOD +C +C The routine applies the elementary reflector H, taking the special +C structure of C into account. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Based on LAPACK routines DLARFX and DLATZM. +C +C REVISIONS +C +C Dec. 1997. +C +C KEYWORDS +C +C Elementary matrix operations, elementary reflector, orthogonal +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER LDA, LDB, M, N + DOUBLE PRECISION TAU +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) +C .. Local Scalars .. + INTEGER J + DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, + $ V3, V4, V5, V6, V7, V8, V9 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +C +C .. Executable Statements .. +C + IF( TAU.EQ.ZERO ) + $ RETURN +C +C Form H * C, where H has order m+1. +C + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 ) M+1 +C +C Code for general M. Compute +C +C w := C'*u, C := C - tau * u * w'. +C + CALL DCOPY( N, A, LDA, DWORK, 1 ) + CALL DGEMV( 'Transpose', M, N, ONE, B, LDB, V, 1, ONE, DWORK, 1 ) + CALL DAXPY( N, -TAU, DWORK, 1, A, LDA ) + CALL DGER( M, N, -TAU, V, 1, DWORK, 1, B, LDB ) + GO TO 210 + 10 CONTINUE +C +C Special code for 1 x 1 Householder +C + T1 = ONE - TAU + DO 20 J = 1, N + A( 1, J ) = T1*A( 1, J ) + 20 CONTINUE + GO TO 210 + 30 CONTINUE +C +C Special code for 2 x 2 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + DO 40 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + 40 CONTINUE + GO TO 210 + 50 CONTINUE +C +C Special code for 3 x 3 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 60 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + 60 CONTINUE + GO TO 210 + 70 CONTINUE +C +C Special code for 4 x 4 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + DO 80 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + 80 CONTINUE + GO TO 210 + 90 CONTINUE +C +C Special code for 5 x 5 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + DO 100 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + 100 CONTINUE + GO TO 210 + 110 CONTINUE +C +C Special code for 6 x 6 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + DO 120 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + 120 CONTINUE + GO TO 210 + 130 CONTINUE +C +C Special code for 7 x 7 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + DO 140 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + 140 CONTINUE + GO TO 210 + 150 CONTINUE +C +C Special code for 8 x 8 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + DO 160 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + + $ V7*B( 7, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + B( 7, J ) = B( 7, J ) - SUM*T7 + 160 CONTINUE + GO TO 210 + 170 CONTINUE +C +C Special code for 9 x 9 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + DO 180 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + + $ V7*B( 7, J ) + V8*B( 8, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + B( 7, J ) = B( 7, J ) - SUM*T7 + B( 8, J ) = B( 8, J ) - SUM*T8 + 180 CONTINUE + GO TO 210 + 190 CONTINUE +C +C Special code for 10 x 10 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + DO 200 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + + $ V7*B( 7, J ) + V8*B( 8, J ) + V9*B( 9, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + B( 7, J ) = B( 7, J ) - SUM*T7 + B( 8, J ) = B( 8, J ) - SUM*T8 + B( 9, J ) = B( 9, J ) - SUM*T9 + 200 CONTINUE + 210 CONTINUE + RETURN +C *** Last line of MB04OY *** + END diff --git a/modules/cacsd/src/slicot/mb04oy.lo b/modules/cacsd/src/slicot/mb04oy.lo new file mode 100755 index 000000000..80a225983 --- /dev/null +++ b/modules/cacsd/src/slicot/mb04oy.lo @@ -0,0 +1,12 @@ +# src/slicot/mb04oy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mb04oy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/polmc.f b/modules/cacsd/src/slicot/polmc.f new file mode 100755 index 000000000..5636d911c --- /dev/null +++ b/modules/cacsd/src/slicot/polmc.f @@ -0,0 +1,477 @@ + subroutine polmc(nm,ng,n,m,a,b,g,wr,wi,z,inc,invr,ierr,jpvt, + x rm1,rm2,rv1,rv2,rv3,rv4) +c + double precision a(nm,n),b(nm,m),g(ng,n),wr(n),wi(n),z(nm,n), + x rm1(m,m),rm2(m,*),rv1(n),rv2(n),rv3(m),rv4(m) + double precision p,q,r,s,t,zz + integer invr(n),jpvt(m) + logical complx +c!purpose +c this subroutine determines the state feedback matrix g of the +c linear time-invariant multi-input system +c +c dx / dt = a * x + b * u, +c +c where a is a nxn and b is a nxm matrix, such that the +c closed-loop system +c +c dx / dt = (a - b * g) * x +c +c has desired poles. the system must be preliminary reduced into +c orthogonal canonical form using the subroutine trmcf. +c!calling sequence +c +c subroutine polmc(nm,ng,n,m,a,b,g,wr,wi,z,inc,invr,ierr,jpvt, +c x rm1,rm2,rv1,rv2,rv3,rv4) +c +c on input- +c +c nm is an integer variable set equal to the row dimension +c of the two-dimensional arrays a, b and z as +c specified in the dimension statements for a, b and z +c in the calling program, +c +c ng is an integer variable set equal to the row dimension +c of the two-dimensional array g as specified in the +c dimension statement for g in the calling program, +c +c n is an integer variable set equal to the order of the +c matrices a and z. n must be not greater than nm, +c +c m is an integer variable set equal to the number of the +c columns of the matrix b. m must be not greater than +c ng, +c +c a is a working precision real two-dimensional variable with +c row dimension nm and column dimension at least n +c containing the block-hessenberg canonical form of the +c matrix a. the elements below the subdiagonal blocks +c must be equal to zero, +c +c b is a working precision real two-dimensional variable with +c row dimension nm and column dimension at least m +c containing the canonical form of the matrix b. the +c elements below the invr(1)-th row must be equal to zero, +c +c wr,wi are working precision real one-dimensional variables +c of dimension at least n containing the real and +c imaginery parts, respectively, of the desired poles, +c the poles can be unordered except that the complex +c conjugate pairs of poles must appfar consecutively. +c note that on output the imaginery parts of the poles +c may be modified, +c +c z is a working precision real two-dimensonal variale with +c row dimension nm and column dimension at least n +c containing the orthogonal transformation matrix produced +c in trmcf which reduces the system into canonical form, +c +c inc is an integer variable set equal to the controllability +c index of the system, +c +c invr is an integer one-dimensional variable of dimension at +c least inc containing the dimensons of the +c controllable subsystems in the canonical form. +c +c on output- +c +c a contains the upper quast-triangular form of the closed- +c loop system matrix a - b * g, that is triangular except +c of possible 2x2 blocks on the diagonal, +c +c b contains the transformed matrix b, +c +c g is a working precision real two-dimensional variable with +c row dimension ng and column dimension at least n +c containing the state feedback matrix g of the original +c system, +c +c z contains the orthogonal matrix which reduces the closed- +c loop system matrix a - b * g to the upper quasi- +c triangular form, +c +c ierr is an integer variable set equal to +c zero for normal return, +c 1 if the system is not completely controllable, +c +c jpvt is an integer temporary one-dimensonal array of +c dimension at least m used in the solution of linear +c equations, +c +c rm1 is a working precision real temporary two-dimensonal +c array of dimension at least mxm used in the solution +c of linear equations, +c +c rm2 is a working precision real temporary two-dimensional +c array od dimension at least mxmax(2,m) used in the +c solution of linear equations, +c +c rv1, are working precision real temporary one-dimensional +c rv2 arrays of dimension at least n used to hold the +c real and imaginery parts, respectively, of the +c eigenvectors during the reduction, +c +c rv3, are working precision real temporary one-dimensional +c rv4 arrays of dimension at least m used in the solution +c of linear equations. +c +c!auxiliary routines +c +c sqrsm +c fortran abs,min,sqrt +c!originator +c p.hr.petkov, higher institute of mechanical and electrical +c engineering, sofia, bulgaria. +c modified by serge Steer INRIA +c Copyright SLICOT +c! +c + ierr = 0 + m1 = invr(1) + l = 0 + 10 l = l + 1 + mr = invr(inc) + if (inc .eq. 1) go to 350 + lp1 = l + m1 + inc1 = inc - 1 + mr1 = invr(inc1) + nr = n - mr + 1 + nr1 = nr - mr1 + complx = wi(l) .ne. 0.0d+0 + do 15 i = nr, n + rv1(i) = 0.0d+0 + if (complx) rv2(i) = 0.0d+0 + 15 continue +c + rv1(nr) = 1.0d+0 + if (.not. complx) go to 20 + if (mr .eq. 1) rv2(nr) = 1.0d+0 + if (mr .gt. 1) rv2(nr+1) = 1.0d+0 + t = wi(l) + wi(l) = 1.0d+0 + wi(l+1) = t * wi(l+1) +c +c compute and transform eigenvector +c + 20 do 200 ip = 1, inc + if (ip .eq. inc .and. inc .eq. 2) go to 200 + if (ip .eq. inc) go to 120 +c + do 40 ii = 1, mr + i = nr + ii - 1 +c + do 30 jj = 1, mr1 + j = nr1 + jj - 1 + rm1(ii,jj) = a(i,j) + 30 continue +c + 40 continue +c + if (ip .eq. 1) go to 70 +c +c scaling +c + s = 0.0d+0 + mp1 = mr + 1 + np1 = nr + mp1 +c + do 50 ii = 1, mp1 + i = nr + ii - 1 + s = s + abs(rv1(i)) + if (complx) s = s + abs(rv2(i)) + 50 continue +c + do 60 ii = 1, mp1 + i = nr + ii - 1 + rv1(i) = rv1(i) / s + if (complx) rv2(i) = rv2(i) / s + 60 continue +c + if (complx .and. np1 .le. n) rv2(np1) = rv2(np1) / s + 70 if (ip .eq. 1) mp1 = 1 + np1 = nr + mp1 +c + do 100 ii = 1, mr + i = nr + ii - 1 + s = wr(l) * rv1(i) +c + do 80 jj = 1, mp1 + j = nr + jj - 1 + s = s - a(i,j) * rv1(j) + 80 continue +c + rm2(ii,1) = s + if (.not. complx) go to 100 + rm2(ii,1) = rm2(ii,1) + wi(l+1) * rv2(i) + s = wr(l+1) * rv2(i) + wi(l) * rv1(i) +c + do 90 jj = 1, mp1 +c la ligne suivante a ete rajoutee par mes soins + j = nr + jj - 1 + s = s - a(i,j) * rv2(j) + 90 continue +c + if (np1 .le. n) s = s - a(i,np1) * rv2(np1) + rm2(ii,2) = s + 100 continue +c +c solving linear equations for the eigenvector elements +c + nc = 1 + if (complx) nc = 2 + call dqrsm(rm1,m,mr,mr1,rm2,m,nc,rm2,m,ir,jpvt, + x rv3,rv4) + if (ir .lt. mr) go to 600 +c + do 110 ii = 1, mr1 + i = nr1 + ii - 1 + rv1(i) = rm2(ii,1) + if (complx) rv2(i) = rm2(ii,2) + 110 continue +c + if (ip .eq. 1 .and. inc .gt. 2) go to 195 + 120 nj = nr + if (ip .lt. inc) nj = nr1 + ni = nr + mr - 1 + inc2 = inc - ip + 2 + if (ip .gt. 1) ni = ni + invr(inc2) + if (ip .gt. 2) ni = ni + 1 + if (complx .and. ip .gt. 2) ni = min(ni+1,n) + kmr = mr1 + if (ip .gt. 1) kmr = mr +c + do 190 kk = 1, kmr + ll = 1 + k = nr + mr - kk + if (ip .eq. 1) k = nr - kk + 130 p = rv1(k) + if (ll .eq. 2) p = rv2(k) + q = rv1(k+1) + if (ll .eq. 2) q = rv2(k+1) + s = abs(p) + abs(q) + p = p / s + q = q / s + r = sqrt(p*p+q*q) + t = s * r + rv1(k) = t + if (ll .eq. 2) rv2(k) = t + rv1(k+1) = 0.0d+0 + if (ll .eq. 2) rv2(k+1) = 0.0d+0 + p = p / r + q = q / r +c +c transform a +c + do 140 j = nj, n + zz = a(k,j) + a(k,j) = p * zz + q * a(k+1,j) + a(k+1,j) = p * a(k+1,j) - q * zz + 140 continue +c + do 150 i = 1, ni + zz = a(i,k) + a(i,k) = p * zz + q * a(i,k+1) + a(i,k+1) = p * a(i,k+1) - q * zz + 150 continue +c + if (k .eq. lp1 .and. ll .eq. 1 .or. k .gt. lp1) go to 170 +c +c transform b +c + do 160 j = 1, m + zz = b(k,j) + b(k,j) = p * zz + q * b(k+1,j) + b(k+1,j) = p * b(k+1,j) - q * zz + 160 continue +c +c accumulate transformations +c + 170 do 180 i = 1, n + zz = z(i,k) + z(i,k) = p * zz + q * z(i,k+1) + z(i,k+1) = p * z(i,k+1) - q * zz + 180 continue +c + if (.not. complx .or. ll .eq. 2) go to 190 + zz = rv2(k) + rv2(k) = p * zz + q * rv2(k+1) + rv2(k+1) = p * rv2(k+1) - q * zz + if (k + 2 .gt. n) go to 190 + k = k + 1 + ll = 2 + go to 130 + 190 continue +c + if (ip .eq. inc) go to 200 + 195 mr = mr1 + nr = nr1 + if (ip .eq. inc1) go to 200 + inc2 = inc - ip - 1 + mr1 = invr(inc2) + nr1 = nr1 - mr1 + 200 continue +c + if (complx) go to 250 +c +c find one column of g +c + do 220 ii = 1, m1 + i = l + ii +c + do 210 j = 1, m + 210 rm1(ii,j) = b(i,j) +c + rm2(ii,1) = a(i,l) + 220 continue +c + call dqrsm(rm1,m,m1,m,rm2,m,1,g(1,l),ng,ir,jpvt,rv3,rv4) + if (ir .lt. m1) go to 600 +c + do 240 i = 1, lp1 +c + do 230 j = 1, m + 230 a(i,l) = a(i,l) - b(i,j) * g(j,l) +c + 240 continue +c + go to 330 +c +c find two columns of g +c + 250 l = l + 1 + if (lp1 .lt. n) lp1 = lp1 + 1 +c + do 270 ii = 1, m1 + i = l + ii + if (l + m1 .gt. n) i = i - 1 +c +c la ligne suivante a ete rajoutee par mes soins + do 260 j = 1 , m +cxxx if(abs(b(i,j)).le.abs(b(l,j))) i=i-1 + 260 rm1(ii,j) = b(i,j) +c + p = a(i,l-1) + if (i .eq. l) p = p - (rv2(i) / rv1(i-1)) * wi(i) + rm2(ii,1) = p + q = a(i,l) + if (i .eq. l) q = q - wr(i) + (rv2(i-1) / rv1(i-1)) *wi(i) + rm2(ii,2) = q + 270 continue +c + call dqrsm(rm1,m,m1,m,rm2,m,2,rm2,m,ir,jpvt,rv3,rv4) + if (ir .lt. m1) go to 600 +c + do 290 i = 1, m +c + do 280 jj = 1, 2 + j = l + jj - 2 + g(i,j) = rm2(i,jj) + 280 continue +c + 290 continue +c + do 320 i = 1, lp1 +c + do 310 jj = 1, 2 + j = l + jj - 2 +c + do 300 k = 1, m + 300 a(i,j) = a(i,j) - b(i,k)*g(k,j) +c + 310 continue +c + 320 continue +c + if (l .eq. n) go to 500 + 330 invr(inc) = invr(inc) - 1 + if (invr(inc) .eq. 0) inc = inc - 1 + if (complx) invr(inc) = invr(inc) - 1 + if (invr(inc) .eq. 0) inc = inc - 1 + go to 10 +c +c find the rest columns of g +c + 350 do 370 ii = 1, mr + i = l + ii - 1 +c + do 360 j = 1, m + 360 rm1(ii,j) = b(i,j) +c + 370 continue +c + do 400 ii = 1, mr + i = l + ii - 1 +c + do 380 jj = 1, mr + j = l + jj - 1 + if (ii .lt. jj) rm2(ii,jj) = 0.0d+0 + if (ii .gt. jj) rm2(ii,jj) = a(i,j) + 380 continue +c + 400 continue +c + ii = 0 + 410 ii = ii + 1 + i = l + ii - 1 + if (wi(i) .ne. 0.0d+0) go to 420 + rm2(ii,ii) = a(i,i) - wr(i) + if (ii .eq. mr) go to 430 +c la ligne suivante a ete rajoutee par mes soins + goto 410 + 420 rm2(ii,ii) = a(i,i) - wr(i) + rm2(ii,ii+1) = a(i,i+1) - wi(i) + rm2(ii+1,ii) = a(i+1,i) - wi(i+1) + rm2(ii+1,ii+1) = a(i+1,i+1) - wr(i+1) + ii = ii + 1 + if (ii .lt. mr) go to 410 + 430 call dqrsm(rm1,m,mr,m,rm2,m,m,rm2,m,ir,jpvt,rv3,rv4) + if (ir .lt. mr) go to 600 +c + do 450 i = 1, m +c + do 440 jj = 1, mr + j = l + jj - 1 + g(i,j) = rm2(i,jj) + 440 continue +c + 450 continue +c + do 480 i = 1, n +c + do 470 j = l, n +c + do 460 k = 1, m + 460 a(i,j) = a(i,j) - b(i,k) * g(k,j) +c + 470 continue +c + 480 continue +c +c transform g +c + 500 do 540 i = 1, m +c + do 520 j = 1, n + s = 0.0d+0 +c + do 510 k = 1, n + 510 s = s + g(i,k) * z(j,k) +c + rv1(j) = s + 520 continue +c + do 530 j = 1, n + 530 g(i,j) = rv1(j) +c + 540 continue +c + go to 610 +c +c set error -- the system is not completely controllable +c + 600 ierr = 1 + 610 return +c +c last card of subroutine polmc +c + end diff --git a/modules/cacsd/src/slicot/polmc.lo b/modules/cacsd/src/slicot/polmc.lo new file mode 100755 index 000000000..8b0f7972c --- /dev/null +++ b/modules/cacsd/src/slicot/polmc.lo @@ -0,0 +1,12 @@ +# src/slicot/polmc.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/polmc.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/riccpack.f b/modules/cacsd/src/slicot/riccpack.f new file mode 100755 index 000000000..110deae7c --- /dev/null +++ b/modules/cacsd/src/slicot/riccpack.f @@ -0,0 +1,8568 @@ + SUBROUTINE DLALD2( LTRAN, T, LDT, B, LDB, SCALE, X, LDX, XNORM, + $ INFO ) +* +* -- RICCPACK auxiliary routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + LOGICAL LTRAN + INTEGER INFO, LDB, LDT, LDX + DOUBLE PRECISION SCALE, XNORM +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* DLALD2 solves 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. +* +* Arguments +* ========= +* +* LTRAN (input) LOGICAL +* On entry, LTRAN specifies the op(T): +* = .FALSE., op(T) = T, +* = .TRUE., op(T) = T'. +* +* T (input) DOUBLE PRECISION array, dimension (LDT,2) +* On entry, T contains an 2 by 2 matrix. +* +* LDT (input) INTEGER +* The leading dimension of the matrix T. LDT >= 2. +* +* B (input) DOUBLE PRECISION array, dimension (LDB,2) +* On entry, the 2 by 2 matrix B contains the symmetric +* right-hand side of the equation. +* +* LDB (input) INTEGER +* The leading dimension of the matrix B. LDB >= 2. +* +* SCALE (output) DOUBLE PRECISION +* On exit, SCALE contains 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, X contains the 2 by 2 symmetric solution. +* +* LDX (input) INTEGER +* The leading dimension of the matrix X. LDX >= 2. +* +* XNORM (output) DOUBLE PRECISION +* On exit, XNORM is the infinity-norm of the solution. +* +* INFO (output) INTEGER +* On exit, INFO is set to +* 0: successful exit. +* 1: 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. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION FOUR + PARAMETER ( FOUR = 4.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IP, IPSV, J, JP, JPSV, K + DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX +* .. +* .. Local Arrays .. + INTEGER JPIV( 3 ) + DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Do not check the input parameters for errors +* + INFO = 0 +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS +* +* Solve equivalent 3 by 3 system using complete pivoting. +* Set pivots less than SMIN to SMIN. +* + SMIN = MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), + $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) ) + SMIN = MAX( EPS*SMIN, SMLNUM ) + BTMP( 1 ) = ZERO + CALL DCOPY( 9, BTMP, 0, T9, 1 ) + 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 ) + BTMP( 2 ) = B( 2, 1 ) + BTMP( 3 ) = B( 2, 2 ) +* +* Perform elimination +* + DO 50 I = 1, 2 + XMAX = ZERO + DO 20 IP = I, 3 + 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 + 20 CONTINUE + 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 + DO 40 J = I + 1, 3 + T9( J, I ) = T9( J, I ) / T9( I, I ) + BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) + DO 30 K = I + 1, 3 + T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + 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 + DO 70 I = 1, 3 + K = 4 - I + TEMP = ONE / T9( K, K ) + TMP( K ) = BTMP( K )*TEMP + DO 60 J = K + 1, 3 + TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) + 60 CONTINUE + 70 CONTINUE + 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 + X( 1, 1 ) = TMP( 1 ) + X( 2, 1 ) = TMP( 2 ) + X( 1, 2 ) = TMP( 2 ) + X( 2, 2 ) = TMP( 3 ) + XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 2 ) ), + $ ABS( TMP( 2 ) )+ABS( TMP( 3 ) ) ) + RETURN +* +* End of DLALD2 +* + END + SUBROUTINE DLALY2( LTRAN, T, LDT, B, LDB, SCALE, X, LDX, XNORM, + $ INFO ) +* +* -- RICCPACK auxiliary routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + LOGICAL LTRAN + INTEGER INFO, LDB, LDT, LDX + DOUBLE PRECISION SCALE, XNORM +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* DLALY2 solves 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. +* +* Arguments +* ========= +* +* LTRAN (input) LOGICAL +* On entry, LTRAN specifies the op(T): +* = .FALSE., op(T) = T, +* = .TRUE., op(T) = T'. +* +* T (input) DOUBLE PRECISION array, dimension (LDT,2) +* On entry, T contains an 2 by 2 matrix. +* +* LDT (input) INTEGER +* The leading dimension of the matrix T. LDT >= 2. +* +* B (input) DOUBLE PRECISION array, dimension (LDB,2) +* On entry, the 2 by 2 matrix B contains the symmetric +* right-hand side of the equation. +* +* LDB (input) INTEGER +* The leading dimension of the matrix B. LDB >= 2. +* +* SCALE (output) DOUBLE PRECISION +* On exit, SCALE contains 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, X contains the 2 by 2 symmetric solution. +* +* LDX (input) INTEGER +* The leading dimension of the matrix X. LDX >= 2. +* +* XNORM (output) DOUBLE PRECISION +* On exit, XNORM is the infinity-norm of the solution. +* +* INFO (output) INTEGER +* On exit, INFO is set to +* 0: successful exit. +* 1: 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. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION FOUR + PARAMETER ( FOUR = 4.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IP, IPSV, J, JP, JPSV, K + DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX +* .. +* .. Local Arrays .. + INTEGER JPIV( 3 ) + DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Do not check the input parameters for errors +* + INFO = 0 +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS +* +* Solve equivalent 3 by 3 system using complete pivoting. +* Set pivots less than SMIN to SMIN. +* + SMIN = MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), + $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) ) + SMIN = MAX( EPS*SMIN, SMLNUM ) + BTMP( 1 ) = ZERO + CALL DCOPY( 9, BTMP, 0, T9, 1 ) + T9( 1, 1 ) = T( 1, 1 ) + T( 1, 1 ) + T9( 2, 2 ) = T( 1, 1 ) + T( 2, 2 ) + T9( 3, 3 ) = T( 2, 2 ) + T( 2, 2 ) + IF( LTRAN ) THEN + T9( 1, 2 ) = T( 1, 2 ) + T( 1, 2 ) + T9( 2, 1 ) = T( 2, 1 ) + T9( 2, 3 ) = T( 1, 2 ) + T9( 3, 2 ) = T( 2, 1 ) + T( 2, 1 ) + ELSE + T9( 1, 2 ) = T( 2, 1 ) + T( 2, 1 ) + T9( 2, 1 ) = T( 1, 2 ) + T9( 2, 3 ) = T( 2, 1 ) + T9( 3, 2 ) = T( 1, 2 ) + T( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + BTMP( 3 ) = B( 2, 2 ) +* +* Perform elimination +* + DO 50 I = 1, 2 + XMAX = ZERO + DO 20 IP = I, 3 + 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 + 20 CONTINUE + 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 + DO 40 J = I + 1, 3 + T9( J, I ) = T9( J, I ) / T9( I, I ) + BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) + DO 30 K = I + 1, 3 + T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + 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 + DO 70 I = 1, 3 + K = 4 - I + TEMP = ONE / T9( K, K ) + TMP( K ) = BTMP( K )*TEMP + DO 60 J = K + 1, 3 + TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) + 60 CONTINUE + 70 CONTINUE + 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 + X( 1, 1 ) = TMP( 1 ) + X( 2, 1 ) = TMP( 2 ) + X( 1, 2 ) = TMP( 2 ) + X( 2, 2 ) = TMP( 3 ) + XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 2 ) ), + $ ABS( TMP( 2 ) )+ABS( TMP( 3 ) ) ) + RETURN +* +* End of DLALY2 +* + END + SUBROUTINE DLASD2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, + $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) +* +* -- RICCPACK auxiliary routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + LOGICAL LTRANL, LTRANR + INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 + DOUBLE PRECISION SCALE, XNORM +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), + $ X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* DLASD2 solves 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. +* +* Arguments +* ========= +* +* LTRANL (input) LOGICAL +* On entry, LTRANL specifies the op(TL): +* = .FALSE., op(TL) = TL, +* = .TRUE., op(TL) = TL'. +* +* LTRANR (input) LOGICAL +* On entry, LTRANR specifies the op(TR): +* = .FALSE., op(TR) = TR, +* = .TRUE., op(TR) = TR'. +* +* ISGN (input) INTEGER +* On entry, ISGN specifies the sign of the equation +* as described before. ISGN may only be 1 or -1. +* +* N1 (input) INTEGER +* On entry, N1 specifies the order of matrix TL. +* N1 may only be 0, 1 or 2. +* +* N2 (input) INTEGER +* On entry, N2 specifies the order of matrix TR. +* N2 may only be 0, 1 or 2. +* +* TL (input) DOUBLE PRECISION array, dimension (LDTL,2) +* On entry, TL contains an N1 by N1 matrix. +* +* LDTL (input) INTEGER +* The leading dimension of the matrix TL. LDTL >= max(1,N1). +* +* TR (input) DOUBLE PRECISION array, dimension (LDTR,2) +* On entry, TR contains an N2 by N2 matrix. +* +* LDTR (input) INTEGER +* The leading dimension of the matrix TR. LDTR >= max(1,N2). +* +* B (input) DOUBLE PRECISION array, dimension (LDB,2) +* On entry, the N1 by N2 matrix B contains the right-hand +* side of the equation. +* +* LDB (input) INTEGER +* The leading dimension of the matrix B. LDB >= max(1,N1). +* +* SCALE (output) DOUBLE PRECISION +* On exit, SCALE contains 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, X contains the N1 by N2 solution. +* +* LDX (input) INTEGER +* The leading dimension of the matrix X. LDX >= max(1,N1). +* +* XNORM (output) DOUBLE PRECISION +* On exit, XNORM is the infinity-norm of the solution. +* +* INFO (output) INTEGER +* On exit, INFO is set to +* 0: successful exit. +* 1: 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. +* +* ====================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION TWO, HALF, EIGHT + PARAMETER ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) +* .. +* .. 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 +* .. +* .. 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 ) +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. 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. / +* .. +* .. Executable Statements .. +* +* Do not check the input parameters for errors +* + INFO = 0 +* +* Quick return if possible +* + IF( N1.EQ.0 .OR. N2.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + SGN = ISGN +* + K = N1 + N1 + N2 - 2 + GO TO ( 10, 20, 30, 50 )K +* +* 1 by 1: SGN*TL11*X*TR11 - X = B11 +* + 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 +* + SCALE = ONE + GAM = ABS( B( 1, 1 ) ) + IF( SMLNUM*GAM.GT.BET ) + $ SCALE = ONE / GAM +* + X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 + XNORM = ABS( X( 1, 1 ) ) + RETURN +* +* 1 by 2: +* ISGN*TL11*[X11 X12]*op[TR11 TR12] = [B11 B12] +* [TR21 TR22] +* + 20 CONTINUE +* + SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), + $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), + $ 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 +* +* 2 by 1: +* ISGN*op[TL11 TL12]*[X11]*TR11 = [B11] +* [TL21 TL22] [X21] [B21] +* + 30 CONTINUE + SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), + $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), + $ 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 +* +* Solve 2 by 2 system using complete pivoting. +* Set pivots less than SMIN to SMIN. +* + 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 + SCALE = ONE + 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( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) + ELSE + X( 2, 1 ) = X2( 2 ) + XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) + END IF + RETURN +* +* 2 by 2: +* ISGN*op[TL11 TL12]*[X11 X12]*op[TR11 TR12]-[X11 X12] = [B11 B12] +* [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] +* +* Solve equivalent 4 by 4 system using complete pivoting. +* Set pivots less than SMIN to SMIN. +* + 50 CONTINUE + SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) + SMIN = MAX( EPS*SMIN, SMLNUM ) + BTMP( 1 ) = ZERO + CALL DCOPY( 16, BTMP, 0, T16, 1 ) + 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 ) + END IF + 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 ) + END IF + 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 ) + END IF + IF( .NOT.LTRANL .AND. .NOT.LTRANR ) THEN + 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 ) +* +* Perform elimination +* + DO 100 I = 1, 3 + XMAX = ZERO + DO 70 IP = I, 4 + 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 + 70 CONTINUE + 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 + DO 90 J = I + 1, 4 + T16( J, I ) = T16( J, I ) / T16( I, I ) + BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) + DO 80 K = I + 1, 4 + T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + IF( ABS( T16( 4, 4 ) ).LT.SMIN ) + $ T16( 4, 4 ) = SMIN + SCALE = ONE + 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 + DO 120 I = 1, 4 + K = 5 - I + TEMP = ONE / T16( K, K ) + TMP( K ) = BTMP( K )*TEMP + DO 110 J = K + 1, 4 + TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) + 110 CONTINUE + 120 CONTINUE + 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 + 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 ) ) ) + RETURN +* +* End of DLASD2 +* + END + SUBROUTINE LYPCFR( TRANA, N, A, LDA, UPLO, C, LDC, T, LDT, U, LDU, + $ X, LDX, SCALE, FERR, WORK, LWORK, IWORK, + $ INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDX, LWORK, N + DOUBLE PRECISION FERR, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), T( LDT, * ), + $ U( LDU, * ), WORK( * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* LYPCFR estimates the forward error bound for the computed solution of +* the matrix Lyapunov equation +* +* transpose(op(A))*X + X*op(A) = scale*C +* +* where op(A) = A or A**T and C is symmetric (C = C**T). A is N-by-N, +* the right hand side C and the solution X are N-by-N, and scale is a +* scale factor, set <= 1 during the solution of the equation to avoid +* overflow in X. If the equation is not scaled, scale should be set +* equal to 1. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of C is stored; +* = 'L': Lower triangle of C is stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N) +* +* T (input) DOUBLE PRECISION array, dimension (LDT,N) +* The upper quasi-triangular matrix in Schur canonical +* form from the Schur factorization of A. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max(1,N) +* +* U (input) DOUBLE PRECISION array, dimension (LDU,N) +* The orthogonal matrix U from the real Schur +* factorization of A. +* +* LDU (input) INTEGER +* The leading dimension of the array U. LDU >= max(1,N) +* +* X (input) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N) +* +* SCALE (input) DOUBLE PRECISION +* The scale factor, scale. +* +* FERR (output) DOUBLE PRECISION +* On exit, 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* LWORK >= 6*N*N. +* +* IWORK (workspace) INTEGER array, dimension (N*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The forward error bound is estimated using the practical error bound +* proposed in [1]. +* +* References +* ========== +* +* [1] N.J. Higham, Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA + CHARACTER TRANAT + INTEGER I, IABS, IDLC, IJ, INFO2, IRES, ITMP, IXBS, J, + $ KASE, MINWRK + DOUBLE PRECISION EPS, EST, SCALE2, XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACON, DLACPY, DSYMM, DSYR2K, LYPCTR, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF +* +* Get the machine precision +* + EPS = DLAMCH( 'Epsilon' ) +* +* Compute workspace +* + MINWRK = 6*N*N + IF( LWORK.LT.MINWRK ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'LYPCFR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + XNORM = DLANSY( '1', UPLO, N, X, LDX, WORK ) + IF( XNORM.EQ.ZERO ) THEN +* +* Matrix all zero +* + FERR = ZERO + RETURN + END IF +* +* Workspace usage +* + IDLC = N*N + ITMP = IDLC + N*N + IABS = ITMP + N*N + IXBS = IABS + N*N + IRES = IXBS + N*N +* + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +* +* Form residual matrix R = C - op(A')*X - X*op(A) +* + CALL DLACPY( UPLO, N, N, C, LDC, WORK( IRES+1 ), N ) + CALL DSYR2K( UPLO, TRANAT, N, N, -ONE, A, LDA, X, LDX, SCALE, + $ WORK( IRES+1 ), N ) +* +* Add to abs(R) a term that takes account of rounding errors in +* forming R: +* abs(R) := abs(R) + EPS*(3*abs(C) + (n+3)*(abs(op(A'))*abs(X) + +* abs(X)*abs(op(A)))) +* where EPS is the machine precision +* + DO 20 J = 1, N + DO 10 I = 1, N + WORK( IABS+I+(J-1)*N ) = ABS( A( I, J ) ) + WORK( IXBS+I+(J-1)*N ) = ABS( X( I, J ) ) + 10 CONTINUE + 20 CONTINUE + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, WORK( IABS+1 ), N, + $ WORK( IXBS+1 ), N, ZERO, WORK( ITMP+1 ), N ) + IF( LOWER ) THEN + DO 40 J = 1, N + DO 30 I = J, N + WORK( IRES+I+(J-1)*N ) = ABS( WORK( IRES+I+(J-1)*N ) ) + + $ THREE*EPS*SCALE*ABS( C( I, J ) ) + DBLE( N+3 )* + $ EPS*WORK( ITMP+I+(J-1)*N ) + 30 CONTINUE + 40 CONTINUE + ELSE + DO 60 J = 1, N + DO 50 I = 1, J + WORK( IRES+I+(J-1)*N ) = ABS( WORK( IRES+I+(J-1)*N ) ) + + $ THREE*EPS*SCALE*ABS( C( I, J ) ) + DBLE( N+3 )* + $ EPS*WORK( ITMP+I+(J-1)*N ) + 50 CONTINUE + 60 CONTINUE + END IF +* +* Compute forward error bound, using matrix norm estimator +* + EST = ZERO + KASE = 0 + 70 CONTINUE + CALL DLACON( N*(N+1)/2, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IJ = 0 + IF( LOWER ) THEN + DO 90 J = 1, N + DO 80 I = J, N + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Scale by the residual matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ )* + $ WORK( IRES+I+(J-1)*N ) + ELSE +* +* Unpack the lower triangular part of symmetric +* matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + END IF + 80 CONTINUE + 90 CONTINUE + ELSE + DO 110 J = 1, N + DO 100 I = 1, J + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Scale by the residual matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ )* + $ WORK( IRES+I+(J-1)*N ) + ELSE +* +* Unpack the upper triangular part of symmetric +* matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + END IF + 100 CONTINUE + 110 CONTINUE + END IF +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, U, LDU, + $ ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK, N, ZERO, + $ WORK( ITMP+1 ), N ) + IF( KASE.EQ.2 ) THEN +* +* Solve op(A')*Y + Y*op(A) = scale2*RHS +* + CALL LYPCTR( TRANA, N, T, LDT, WORK( ITMP+1 ), N, SCALE2, + $ INFO2 ) + ELSE +* +* Solve op(A)*Z + Z*op(A') = scale2*RHS +* + CALL LYPCTR( TRANAT, N, T, LDT, WORK( ITMP+1 ), N, SCALE2, + $ INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, U, LDU, + $ ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) + IJ = 0 + IF( LOWER ) THEN + DO 130 J = 1, N + DO 120 I = J, N + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Pack the lower triangular part of symmetric +* matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + ELSE +* +* Scale by the residual matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N )* + $ WORK( IRES+I+(J-1)*N ) + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 150 J = 1, N + DO 140 I = 1, J + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Pack the upper triangular part of symmetric +* matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + ELSE +* +* Scale by the residual matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N )* + $ WORK( IRES+I+(J-1)*N ) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + GO TO 70 + END IF +* +* Compute the estimate of the forward error +* + FERR = TWO*EST / + $ DLANSY( 'Max', UPLO, N, X, LDX, WORK ) / SCALE2 + IF( FERR.GT.ONE ) FERR = ONE +* + RETURN +* +* End of LYPCFR +* + END + SUBROUTINE LYPCRC( FACT, TRANA, N, A, LDA, UPLO, C, LDC, T, LDT, + $ U, LDU, X, LDX, SCALE, RCOND, WORK, LWORK, + $ IWORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER FACT, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDX, LWORK, N + DOUBLE PRECISION RCOND, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), T( LDT, * ), + $ U( LDU, * ), WORK( * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* LYPCRC estimates the reciprocal of the condition number of the matrix +* Lyapunov equation +* +* transpose(op(A))*X + X*op(A) = scale*C +* +* where op(A) = A or A**T and C is symmetric (C = C**T). A is N-by-N, +* the right hand side C and the solution X are N-by-N, and scale is a +* scale factor, set <= 1 during the solution of the equation to avoid +* overflow in X. If the equation is not scaled, scale should be set +* equal to 1. +* +* Arguments +* ========= +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the real Schur factorization +* of the matrix A is supplied on entry: +* = 'F': On entry, T 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 T and U. +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of C is stored; +* = 'L': Lower triangle of C is stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N) +* +* T (input or output) DOUBLE PRECISION array, dimension (LDT,N) +* If FACT = 'F', then T is an input argument and on entry +* contains the upper quasi-triangular matrix in Schur canonical +* form from the Schur factorization of A. +* If FACT = 'N', then T is an output argument and on exit +* returns the upper quasi-triangular matrix in Schur +* canonical form from the Schur factorization of A. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= 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 +* contains the orthogonal matrix U from the real Schur +* factorization of A. +* If FACT = 'N', then U is an output argument and on exit +* returns the orthogonal N-by-N matrix from the real Schur +* factorization of A. +* +* LDU (input) INTEGER +* The leading dimension of the array U. LDU >= max(1,N) +* +* X (input) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N) +* +* SCALE (input) DOUBLE PRECISION +* The scale factor, scale. +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number +* of the Lyapunov equation. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* LWORK >= 3*N*N + 2*N + max(1,3*N). +* For good performance, LWORK must generally be larger. +* +* IWORK (workspace) INTEGER array, dimension (N*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: the matrix A cannot be reduced to Schur canonical form +* +* Further Details +* =============== +* +* The condition number of the 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(Z) = transpose(op(A))*Z + Z*op(A), +* Theta(Z) = inv(Omega(transpose(op(Z))*X + X*op(Z))). +* +* The program estimates the quantities +* +* sep(op(A),-transpose(op(A)) = 1 / norm(inv(Omega)) +* +* and norm(Theta) using 1-norm condition estimator. +* +* References +* ========== +* +* [1] N.J. Higham, Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOFACT, NOTRNA, VOIDDUMMY + CHARACTER TRANAT + INTEGER I, IDLC, IJ, INFO2, ITMP, IWI, IWR, IWRK, J, + $ KASE, LWA, MINWRK, SDIM + DOUBLE PRECISION ANORM, CNORM, EST, SCALE2, SEP, THNORM, XNORM +* .. +* .. Local Arrays .. + LOGICAL BWORK( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANGE, DLANSY + EXTERNAL DLANGE, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DLACON, DLACPY, DSYMM, DSYR2K, + $ LYPCTR, XERBLA, VOIDDUMMY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + INFO = 0 + IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. + $ LSAME( TRANA, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF +* +* Compute workspace +* + MINWRK = 3*N*N + 2*N + MAX( 1, 3*N ) + IF( LWORK.LT.MINWRK ) THEN + INFO = -18 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'LYPCRC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Compute the norms of the matrices A, C and X +* + ANORM = DLANGE( '1', N, N, A, LDA, WORK ) + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + XNORM = DLANSY( '1', UPLO, N, X, LDX, WORK ) + IF( XNORM.EQ.ZERO ) THEN +* +* Matrix all zero +* + RCOND = ZERO + RETURN + END IF +* +* Workspace usage +* + LWA = 3*N*N + 2*N + IDLC = N*N + ITMP = IDLC + N*N + IWR = ITMP + N*N + IWI = IWR + N + IWRK = IWI + N +* + IF( NOFACT ) THEN +* +* Compute the Schur factorization of A +* + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + CALL DGEES( 'V', 'N', VOIDDUMMY, N, T, LDT, SDIM, + $ WORK( IWR+1 ), + $ WORK( IWI+1 ), U, LDU, WORK( IWRK+1 ), LWORK-IWRK, + $ BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWA = LWA + INT( WORK( IWRK+1 ) ) + END IF +* +* Estimate sep(op(A),-transpose(op(A))) +* + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +* + EST = ZERO + KASE = 0 + 10 CONTINUE + CALL DLACON( N*(N+1)/2, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +* +* Unpack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 30 J = 1, N + DO 20 I = J, N + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 20 CONTINUE + 30 CONTINUE + ELSE + DO 50 J = 1, N + DO 40 I = 1, J + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 40 CONTINUE + 50 CONTINUE + END IF +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, U, LDU, + $ ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK, N, ZERO, + $ WORK( ITMP+1 ), N ) + IF( KASE.EQ.1 ) THEN +* +* Solve op(A')*Y + Y*op(A) = scale2*RHS +* + CALL LYPCTR( TRANA, N, T, LDT, WORK( ITMP+1 ), N, SCALE2, + $ INFO2 ) + ELSE +* +* Solve op(A)*Z + Z*op(A') = scale2*RHS +* + CALL LYPCTR( TRANAT, N, T, LDT, WORK( ITMP+1 ), N, SCALE2, + $ INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, U, LDU, + $ ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) +* +* Pack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 70 J = 1, N + DO 60 I = J, N + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 60 CONTINUE + 70 CONTINUE + ELSE + DO 90 J = 1, N + DO 80 I = 1, J + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 80 CONTINUE + 90 CONTINUE + END IF + GO TO 10 + END IF +* + SEP = SCALE2 / TWO / EST +* +* Return if the equation is singular +* + IF( SEP.EQ.ZERO ) THEN + RCOND = ZERO + RETURN + END IF +* +* Estimate norm(Theta) +* + EST = ZERO + KASE = 0 + 100 CONTINUE + CALL DLACON( N*N, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +* +* Compute RHS = op(W')*X + X*op(W) +* + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, WORK, N, X, LDX, ZERO, + $ WORK( ITMP+1 ), N ) + CALL DLACPY( UPLO, N, N, WORK( ITMP+1 ), N, WORK, N ) +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK( ITMP+1 ), + $ N, ZERO, WORK, N ) + IF( KASE.EQ.1 ) THEN +* +* Solve op(A')*Y + Y*op(A) = scale2*RHS +* + CALL LYPCTR( TRANA, N, T, LDT, WORK, N, SCALE2, INFO2 ) + ELSE +* +* Solve op(A)*Z + Z*op(A') = scale2*RHS +* + CALL LYPCTR( TRANAT, N, T, LDT, WORK, N, SCALE2, INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK( ITMP+1 ), N, U, + $ LDU, ZERO, WORK, N ) + GO TO 100 + END IF +* + THNORM = EST / SCALE2 +* +* Estimate the reciprocal condition number +* + RCOND = SEP*XNORM / ( CNORM*SCALE + SEP*( THNORM*ANORM ) ) + IF( RCOND.GT.ONE ) RCOND = ONE +* + WORK( 1 ) = DBLE( LWA ) + RETURN +* +* End of LYPCRC +* + END + SUBROUTINE LYPCSL( FACT, TRANA, N, A, LDA, UPLO, C, LDC, T, LDT, + $ U, LDU, WR, WI, X, LDX, SCALE, RCOND, FERR, + $ WORK, LWORK, IWORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER FACT, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDX, LWORK, N + DOUBLE PRECISION FERR, RCOND, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), T( LDT, * ), + $ U( LDU, * ), WI( * ), WORK( * ), WR( * ), + $ X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* LYPCSL solves the matrix Lyapunov equation +* +* transpose(op(A))*X + X*op(A) = scale*C +* +* where op(A) = A or A**T and C is symmetric (C = C**T). 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 <= 1 to avoid overflow in X. +* +* Error bound on the solution and condition estimate are also provided. +* +* Arguments +* ========= +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the real Schur factorization +* of the matrix A is supplied on entry: +* = 'F': On entry, T 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 T and U. +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of C is stored; +* = 'L': Lower triangle of C is stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N) +* +* T (input or output) DOUBLE PRECISION array, dimension (LDT,N) +* If FACT = 'F', then T is an input argument and on entry +* contains the upper quasi-triangular matrix in Schur canonical +* form from the Schur factorization of A. +* If FACT = 'N', then T is an output argument and on exit +* returns the upper quasi-triangular matrix in Schur +* canonical form from the Schur factorization of A. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= 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 +* contains the orthogonal matrix U from the real Schur +* factorization of A. +* If FACT = 'N', then U is an output argument and on exit +* returns the orthogonal N-by-N matrix from the real Schur +* factorization of A. +* +* LDU (input) INTEGER +* The leading dimension of the array U. LDU >= max(1,N) +* +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) +* On exit, if FACT = 'N', WR(1:N) and WI(1:N) contain the +* real and imaginary parts, respectively, of the eigenvalues +* of A. +* If FACT = 'F', WR and WI are not referenced. +* +* X (output) DOUBLE PRECISION array, dimension (LDX,N) +* If INFO = 0, the N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N) +* +* SCALE (output) DOUBLE PRECISION +* The scale factor, scale, set <= 1 to avoid overflow in X. +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number +* of the Lyapunov equation. +* +* FERR (output) DOUBLE PRECISION +* On exit, 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* LWORK >= 6*N*N + max(1,3*N). +* For good performance, LWORK must generally be larger. +* +* IWORK (workspace) INTEGER array, dimension (N*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: the matrix A cannot be reduced to Schur canonical form +* = 2: A and -transpose(A) have common or very close +* eigenvalues; perturbed values were used to solve the +* equation (but the matrix A is unchanged). +* +* Further Details +* =============== +* +* The matrix Lyapunov equation is solved by the Bartels-Stewart +* algorithm [1]. +* +* The condition number of the equation is estimated using 1-norm +* condition estimator. +* +* The forward error bound is estimated using the practical error bound +* proposed in [2]. +* +* References +* ========== +* +* [1] R.H. Bartels and G.W. Stewart. Algorithm 432: Solution of the +* matrix equation AX + XB = C. Comm. ACM, vol. 15, pp. 820-826, +* 1972. +* [2] N.J. Higham, Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, 1993, pp. 124-136. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOFACT, NOTRNA, VOIDDUMMY + INTEGER INFO2, LWA, LWAMAX, MINWRK, SDIM + DOUBLE PRECISION CNORM +* .. +* .. Local Arrays .. + LOGICAL BWORK( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DLACPY, DLASET, DSYMM, LYPCFR, + $ LYPCRC, LYPCTR, XERBLA, VOIDDUMMY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + INFO = 0 + IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. + $ LSAME( TRANA, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF +* +* Compute workspace +* + MINWRK = 6*N*N + MAX( 1, 3*N ) + IF( LWORK.LT.MINWRK ) THEN + INFO = -21 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'LYPCSL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + IF( CNORM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution +* + CALL DLASET( 'F', N, N, ZERO, ZERO, X, LDX ) + SCALE = ONE + RCOND = ZERO + FERR = ZERO + RETURN + END IF +* + LWA = 0 +* + IF( NOFACT ) THEN +* +* Compute the Schur factorization of A +* + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + CALL DGEES( 'V', 'N', VOIDDUMMY, N, T, LDT, SDIM, + $ WR, WI, + $ U, LDU, + $ WORK, LWORK, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWA = INT( WORK( 1 ) ) + END IF + LWAMAX = LWA +* +* Transform the right-hand side: C := U'*C*U. +* Form TEMP = C*U then X = U'*TEMP +* + CALL DSYMM( 'L', UPLO, N, N, ONE, C, LDC, U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK, N, ZERO, X, + $ LDX ) +* +* Solve the quasi-triangular Lyapunov equation. +* The answer overwrites the right-hand side +* + CALL LYPCTR( TRANA, N, T, LDT, X, LDX, SCALE, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + END IF +* +* Transform back to obtain the solution: X := U*X*U'. +* Form TEMP = U*X then X = TEMP*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, X, LDX, U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, U, LDU, ZERO, X, + $ LDX ) +* +* Estimate the reciprocal of the condition number +* + CALL LYPCRC( 'F', TRANA, N, A, LDA, UPLO, C, LDC, T, LDT, U, LDU, + $ X, LDX, SCALE, RCOND, WORK, LWORK, IWORK, INFO2 ) +* +* Return if the equation is singular +* + IF( RCOND.EQ.ZERO ) THEN + FERR = ONE + RETURN + END IF + LWA = INT( WORK( 1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Estimate the bound on the forward error +* + CALL LYPCFR( TRANA, N, A, LDA, UPLO, C, LDC, T, LDT, U, LDU, + $ X, LDX, SCALE, FERR, WORK, LWORK, IWORK, INFO2 ) + LWA = 6*N*N + LWAMAX = MAX( LWA, LWAMAX ) +* + WORK( 1 ) = DBLE( LWAMAX ) + RETURN +* +* End of LYPCSL +* + END + SUBROUTINE LYPCTR( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA + INTEGER INFO, LDA, LDC, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ) +* .. +* +* Purpose +* ======= +* +* LYPCTR solves the matrix Lyapunov equation +* +* transpose(op(A))*X + X*op(A) = scale*C +* +* where op(A) = A or A**T, A is upper quasi-triangular and C is +* symmetric (C = C**T). 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 <= 1 to avoid overflow in X. +* +* A must be in Schur canonical form (as returned by 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. +* +* Arguments +* ========= +* +* TRANA (input) CHARACTER*1 +* Specifies the option op(A): +* = 'N': op(A) = A (No transpose) +* = 'T': op(A) = A**T (Transpose) +* = 'C': op(A) = A**H (Conjugate transpose = Transpose) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The upper quasi-triangular matrix A, in Schur canonical form. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the symmetric N-by-N right hand side matrix C. +* On exit, C is overwritten by the solution matrix X. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N) +* +* SCALE (output) DOUBLE PRECISION +* The scale factor, scale, set <= 1 to avoid overflow in X. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: A and -A have common or very close eigenvalues; +* perturbed values were used to solve the equation +* (but the matrix A is unchanged). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRNA + INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT + DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SMIN, + $ SMLNUM, SUML, SUMR, XNORM +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLANGE + EXTERNAL LSAME, DDOT, DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, DLALN2, DLALY2, DLASY2, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) +* + 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 + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'LYPCTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( N*N ) / EPS + BIGNUM = ONE / SMLNUM +* + SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', N, N, A, LDA, DUM ) ) +* + SCALE = ONE +* + IF( NOTRNA ) THEN +* +* Solve A'*X + X*A = scale*C. +* +* The (K,L)th block of X is determined starting from +* upper-left corner column by column by +* +* A(K,K)'*X(K,L) + X(K,L)*A(L,L) = C(K,L) - R(K,L) +* +* Where +* K-1 L-1 +* R(K,L) = SUM [A(I,K)'*X(I,L)] +SUM [X(K,J)*A(J,L)] +* I=1 J=1 +* +* Start column loop (index = L) +* L1 (L2): column index of the first (last) row of X(K,L) +* + LNEXT = 1 + DO 60 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 60 + IF( L.EQ.N ) THEN + L1 = L + L2 = L + ELSE + IF( A( L+1, L ).NE.ZERO ) THEN + L1 = L + L2 = L + 1 + LNEXT = L + 2 + ELSE + L1 = L + L2 = L + LNEXT = L + 1 + END IF + END IF +* +* Start row loop (index = K) +* K1 (K2): row index of the first (last) row of X(K,L) +* + KNEXT = L + DO 50 K = L, N + IF( K.LT.KNEXT ) + $ GO TO 50 + IF( K.EQ.N ) THEN + K1 = K + K2 = K + ELSE + IF( A( K+1, K ).NE.ZERO ) THEN + K1 = K + K2 = K + 1 + KNEXT = K + 2 + ELSE + K1 = K + K2 = K + KNEXT = K + 1 + END IF + END IF +* + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) + SCALOC = ONE +* + 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 +* + IF( SCALOC.NE.ONE ) THEN + DO 10 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + END IF +* + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SUMR ) +* + 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 +* + IF( SCALOC.NE.ONE ) THEN + DO 20 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 20 CONTINUE + 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 ) +* + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUML+SUMR ) + +* + 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 +* + IF( SCALOC.NE.ONE ) THEN + DO 30 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE + 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 ) +* + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SUMR ) +* + SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + SUMR = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L2 ), 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SUMR ) +* + IF( K1.EQ.L1 ) THEN + CALL DLALY2( .FALSE., A( K1, K1 ), LDA, VEC, 2, + $ SCALOC, X, 2, XNORM, IERR ) + 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 +* + IF( SCALOC.NE.ONE ) THEN + DO 40 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 40 CONTINUE + 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 +* + 50 CONTINUE + 60 CONTINUE +* + ELSE +* +* Solve A*X + X*A' = scale*C. +* +* The (K,L)th block of X is determined starting from +* bottom-right corner column by column by +* +* A(K,K)*X(K,L) + X(K,L)*A(L,L)' = C(K,L) - R(K,L) +* +* Where +* N N +* R(K,L) = SUM [A(K,I)*X(I,L)] + SUM [X(K,J)*A(L,J)']. +* I=K+1 J=L+1 +* +* Start column loop (index = L) +* L1 (L2): column index of the first (last) row of X(K,L) +* + LNEXT = N + DO 120 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 120 + IF( L.EQ.1 ) THEN + L1 = L + L2 = L + ELSE + IF( A( L, L-1 ).NE.ZERO ) THEN + L1 = L - 1 + L2 = L + LNEXT = L - 2 + ELSE + L1 = L + L2 = L + LNEXT = L - 1 + END IF + END IF +* +* Start row loop (index = K) +* K1 (K2): row index of the first (last) row of X(K,L) +* + KNEXT = L + DO 110 K = L, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 110 + IF( K.EQ.1 ) THEN + K1 = K + K2 = K + ELSE + IF( A( K, K-1 ).NE.ZERO ) THEN + K1 = K - 1 + K2 = K + KNEXT = K - 2 + ELSE + K1 = K + K2 = K + KNEXT = K - 1 + END IF + END IF +* + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + SUML = DDOT( N-K1, A( K1, MIN( K1+1, N ) ), LDA, + $ C( MIN( K1+1, N ), L1 ), 1 ) + SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, + $ A( L1, MIN( L1+1, N ) ), LDA ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) + SCALOC = ONE +* + 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 +* + IF( SCALOC.NE.ONE ) THEN + DO 70 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + END IF +* + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( N-K2, A( K1, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L1 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ A( L1, MIN( L2+1, N ) ), LDA ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( N-K2, A( K2, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L1 ), 1 ) + SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, + $ A( L1, MIN( L2+1, N ) ), LDA ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SUMR ) +* + 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 +* + IF( SCALOC.NE.ONE ) THEN + DO 80 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 80 CONTINUE + 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 ) +* + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +* + SUML = DDOT( N-K1, A( K1, MIN( K1+1, N ) ), LDA, + $ C( MIN( K1+1, N ), L1 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ A( L1, MIN( L2+1, N ) ), LDA ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( N-K1, A( K1, MIN( K1+1, N ) ), LDA, + $ C( MIN( K1+1, N ), L2 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ A( L2, MIN( L2+1, N ) ), LDA ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUML+SUMR ) +* + 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 +* + IF( SCALOC.NE.ONE ) THEN + DO 90 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 90 CONTINUE + 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 ) +* + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +* + SUML = DDOT( N-K2, A( K1, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L1 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ A( L1, MIN( L2+1, N ) ), LDA ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( N-K2, A( K1, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L2 ), 1 ) + SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, + $ A( L2, MIN( L2+1, N ) ), LDA ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SUMR ) +* + SUML = DDOT( N-K2, A( K2, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L1 ), 1 ) + SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, + $ A( L1, MIN( L2+1, N ) ), LDA ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( N-K2, A( K2, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L2 ), 1 ) + SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, + $ A( L2, MIN( L2+1, N ) ), LDA ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SUMR ) +* + IF( K1.EQ.L1 ) THEN + CALL DLALY2( .TRUE., A( K1, K1 ), LDA, VEC, 2, + $ SCALOC, X, 2, XNORM, IERR ) + 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 +* + IF( SCALOC.NE.ONE ) THEN + DO 100 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE + 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 +* + 110 CONTINUE + 120 CONTINUE +* + END IF +* + RETURN +* +* End of LYPCTR +* + END + SUBROUTINE LYPDFR( TRANA, N, A, LDA, UPLO, C, LDC, T, LDT, U, LDU, + $ X, LDX, SCALE, FERR, WORK, LWORK, IWORK, + $ INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDX, LWORK, N + DOUBLE PRECISION FERR, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), T( LDT, * ), + $ U( LDU, * ), WORK( * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* LYPDFR estimates the forward error bound for the computed solution of +* the discrete-time matrix Lyapunov equation +* +* transpose(op(A))*X*op(A) - X = scale*C +* +* where op(A) = A or A**T and C is symmetric (C = C**T). A is N-by-N, +* the right hand side C and the solution X are N-by-N, and scale is +* scale factor, set <= 1 during the solution of the equation to avoid +* overflow in X. If the equation is not scaled, scale should be set +* equal to 1. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of C is stored; +* = 'L': Lower triangle of C is stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N) +* +* T (input) DOUBLE PRECISION array, dimension (LDT,N) +* The upper quasi-triangular matrix in Schur canonical +* form from the Schur factorization of A. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max(1,N) +* +* U (input) DOUBLE PRECISION array, dimension (LDU,N) +* The orthogonal matrix U from the real Schur +* factorization of A. +* +* LDU (input) INTEGER +* The leading dimension of the array U. LDU >= max(1,N) +* +* X (input) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N) +* +* SCALE (input) DOUBLE PRECISION +* The scale factor, scale. +* +* FERR (output) DOUBLE PRECISION +* On exit, 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* LWORK >= 7*N*N + 2*N. +* +* IWORK (workspace) INTEGER array, dimension (N*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The forward error bound is estimated using a practical error bound +* similar to the one proposed in [1]. +* +* References +* ========== +* +* [1] N.J. Higham, Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA + CHARACTER TRANAT + INTEGER I, IABS, IDLC, IJ, INFO2, IRES, ITMP, IWRK, + $ IXBS, IXMA, J, KASE, MINWRK + DOUBLE PRECISION EPS, EST, SCALE2, XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACON, DSYMM, LYPDTR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF +* +* Get the machine precision +* + EPS = DLAMCH( 'Epsilon' ) +* +* Compute workspace +* + MINWRK = 7*N*N + 2*N + IF( LWORK.LT.MINWRK ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'LYPDFR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + XNORM = DLANSY( '1', UPLO, N, X, LDX, WORK ) + IF( XNORM.EQ.ZERO ) THEN +* +* Matrix all zero +* + FERR = ZERO + RETURN + END IF +* +* Workspace usage +* + IDLC = N*N + ITMP = IDLC + N*N + IXMA = ITMP + N*N + IABS = IXMA + N*N + IXBS = IABS + N*N + IRES = IXBS + N*N + IWRK = IRES + N*N +* +* Compute X*op(A) +* + CALL DGEMM( 'N', TRANA, N, N, N, ONE, X, LDX, A, LDA, ZERO, + $ WORK( IXMA+1 ), N ) +* + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +* +* Form residual matrix R = C + X - op(A')*X*op(A) +* + CALL DGEMM( TRANAT, 'N', N, N, N, ONE, A, LDA, WORK( IXMA+1 ), N, + $ ZERO, WORK( ITMP+1 ), N ) + IF( LOWER ) THEN + DO 20 J = 1, N + DO 10 I = J, N + WORK( IRES+I+(J-1)*N ) = SCALE*C( I, J ) + X( I, J ) - + $ WORK( ITMP+I+(J-1)*N ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = 1, J + WORK( IRES+I+(J-1)*N ) = SCALE*C( I, J ) + X( I, J ) - + $ WORK( ITMP+I+(J-1)*N ) + 30 CONTINUE + 40 CONTINUE + END IF +* +* Add to abs(R) a term that takes account of rounding errors in +* forming R: +* abs(R) := abs(R) + EPS*(3*abs(C) + 3*abs(X) + +* 2*(n+1)*abs(op(A'))*abs(X)*abs(op(A))) +* where EPS is the machine precision +* + DO 60 J = 1, N + DO 50 I = 1, N + WORK( IABS+I+(J-1)*N ) = ABS( A( I, J ) ) + WORK( IXBS+I+(J-1)*N ) = ABS( X( I, J ) ) + 50 CONTINUE + 60 CONTINUE + CALL DGEMM( 'N', TRANA, N, N, N, ONE, WORK( IXBS+1 ), N, + $ WORK( IABS+1 ), N, ZERO, WORK( IXMA+1 ), N ) + CALL DGEMM( TRANAT, 'N', N, N, N, ONE, WORK( IABS+1 ), N, + $ WORK( IXMA+1 ), N, ZERO, WORK( ITMP+1 ), N ) + IF( LOWER ) THEN + DO 80 J = 1, N + DO 70 I = J, N + WORK( IRES+I+(J-1)*N ) = ABS( WORK( IRES+I+(J-1)*N ) ) + + $ THREE*EPS*( SCALE*ABS( C( I, J ) ) + + $ ABS( X( I, J ) ) ) + DBLE( 2*N + 2 )*EPS* + $ WORK( ITMP+I+(J-1)*N ) + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 J = 1, N + DO 90 I = 1, J + WORK( IRES+I+(J-1)*N ) = ABS( WORK( IRES+I+(J-1)*N ) ) + + $ THREE*EPS*( SCALE*ABS( C( I, J ) ) + + $ ABS( X( I, J ) ) ) + DBLE( 2*N + 2 )*EPS* + $ WORK( ITMP+I+(J-1)*N ) + 90 CONTINUE + 100 CONTINUE + END IF +* +* Compute forward error bound, using matrix norm estimator +* + EST = ZERO + KASE = 0 + 110 CONTINUE + CALL DLACON( N*(N+1)/2, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IJ = 0 + IF( LOWER ) THEN + DO 130 J = 1, N + DO 120 I = J, N + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Scale by the residual matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ )* + $ WORK( IRES+I+(J-1)*N ) + ELSE +* +* Unpack the lower triangular part of symmetric +* matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 150 J = 1, N + DO 140 I = 1, J + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Scale by the residual matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ )* + $ WORK( IRES+I+(J-1)*N ) + ELSE +* +* Unpack the upper triangular part of symmetric +* matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + END IF + 140 CONTINUE + 150 CONTINUE + END IF +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, U, LDU, + $ ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK, N, ZERO, + $ WORK( ITMP+1 ), N ) + IF( KASE.EQ.2 ) THEN +* +* Solve op(A')*Y*op(A) - Y = scale2*RHS +* + CALL LYPDTR( TRANA, N, T, LDT, WORK( ITMP+1 ), N, SCALE2, + $ WORK( IWRK+1 ), INFO2 ) + ELSE +* +* Solve op(A)*Z*op(A') - Z = scale2*RHS +* + CALL LYPDTR( TRANAT, N, T, LDT, WORK( ITMP+1 ), N, SCALE2, + $ WORK( IWRK+1 ), INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, U, LDU, + $ ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) + IJ = 0 + IF( LOWER ) THEN + DO 170 J = 1, N + DO 160 I = J, N + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Pack the lower triangular part of symmetric +* matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + ELSE +* +* Scale by the residual matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N )* + $ WORK( IRES+I+(J-1)*N ) + END IF + 160 CONTINUE + 170 CONTINUE + ELSE + DO 190 J = 1, N + DO 180 I = 1, J + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Pack the upper triangular part of symmetric +* matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + ELSE +* +* Scale by the residual matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N )* + $ WORK( IRES+I+(J-1)*N ) + END IF + 180 CONTINUE + 190 CONTINUE + END IF + GO TO 110 + END IF +* +* Compute the estimate of the forward error +* + FERR = TWO*EST / + $ DLANSY( 'Max', UPLO, N, X, LDX, WORK ) / SCALE2 + IF( FERR.GT.ONE ) FERR = ONE +* + RETURN +* +* End of LYPDFR +* + END + SUBROUTINE LYPDRC( FACT, TRANA, N, A, LDA, UPLO, C, LDC, T, LDT, + $ U, LDU, X, LDX, SCALE, RCOND, WORK, LWORK, + $ IWORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER FACT, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDX, LWORK, N + DOUBLE PRECISION RCOND, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), T( LDT, * ), + $ U( LDU, * ), WORK( * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* LYPDRC estimates the reciprocal of the condition number of the +* discrete-time matrix Lyapunov equation +* +* transpose(op(A))*X*op(A) - X = scale*C +* +* where op(A) = A or A**T and C is symmetric (C = C**T). A is N-by-N, +* the right hand side C and the solution X are N-by-N, and scale is a +* scale factor, set <= 1 during the solution of the equation to avoid +* overflow in X. If the equation is not scaled, scale should be set +* equal to 1. +* +* Arguments +* ========= +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the real Schur factorization +* of the matrix A is supplied on entry: +* = 'F': On entry, T 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 T and U. +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of C is stored; +* = 'L': Lower triangle of C is stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N) +* +* T (input or output) DOUBLE PRECISION array, dimension (LDT,N) +* If FACT = 'F', then T is an input argument and on entry +* contains the upper quasi-triangular matrix in Schur canonical +* form from the Schur factorization of A. +* If FACT = 'N', then T is an output argument and on exit +* returns the upper quasi-triangular matrix in Schur +* canonical form from the Schur factorization of A. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= 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 +* contains the orthogonal matrix U from the real Schur +* factorization of A. +* If FACT = 'N', then U is an output argument and on exit +* returns the orthogonal N-by-N matrix from the real Schur +* factorization of A. +* +* LDU (input) INTEGER +* The leading dimension of the array U. LDU >= max(1,N) +* +* X (input) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N) +* +* SCALE (input) DOUBLE PRECISION +* The scale factor, scale. +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number +* of the discrete-time Lyapunov equation. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* LWORK >= 4*N*N + 2*N + max(1,3*N). +* For good performance, LWORK must generally be larger. +* +* IWORK (workspace) INTEGER array, dimension (N*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: the matrix A cannot be reduced to Schur canonical form +* +* Further Details +* =============== +* +* The condition number of the discrete 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(Z) = transpose(op(A))*Z*op(A) - Z, +* Theta(Z) = inv(Omega(transpose(op(Z))*X*op(A) + +* transpose(op(A))*X*op(Z))). +* +* The program estimates the quantities +* +* sepd(op(A),transpose(op(A)) = 1 / norm(inv(Omega)) +* +* and norm(Theta) using 1-norm condition estimator. +* +* References +* ========== +* +* [1] N.J. Higham, Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOFACT, NOTRNA, VOIDDUMMY + CHARACTER TRANAT + INTEGER I, IDLC, IJ, INFO2, ITMP, IWI, IWR, IWRK, IXMA, + $ J, KASE, LWA, MINWRK, SDIM + DOUBLE PRECISION ANORM, CNORM, EST, SCALE2, SEPD, THNORM, XNORM +* .. +* .. Local Arrays .. + LOGICAL BWORK( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANGE, DLANSY + EXTERNAL DLANGE, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DLACON, DLACPY, DSYMM, DSYR2K, + $ LYPDTR, XERBLA, VOIDDUMMY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + INFO = 0 + IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. + $ LSAME( TRANA, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF +* +* Compute workspace +* + MINWRK = 4*N*N + 2*N + MAX( 1, 3*N ) + IF( LWORK.LT.MINWRK ) THEN + INFO = -18 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'LYPDRC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Compute the norms of the matrices A and C +* + ANORM = DLANGE( '1', N, N, A, LDA, WORK ) + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + XNORM = DLANSY( '1', UPLO, N, X, LDX, WORK ) + IF( XNORM.EQ.ZERO ) THEN +* +* Matrix all zero +* + RCOND = ZERO + RETURN + END IF +* +* Workspace usage +* + LWA = 4*N*N + 2*N + IDLC = N*N + ITMP = IDLC + N*N + IXMA = ITMP + N*N + IWR = IXMA + N*N + IWI = IWR + N + IWRK = IWI + N +* + IF( NOFACT ) THEN +* +* Compute the Schur factorization of A +* + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + CALL DGEES( 'V', 'N', VOIDDUMMY, N, T, LDT, SDIM, + $ WORK( IWR+1 ), + $ WORK( IWI+1 ), U, LDU, WORK( IWRK+1 ), LWORK-IWRK, + $ BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWA = LWA + INT( WORK( IWRK+1 ) ) + END IF +* +* Compute X*op(A) +* + CALL DGEMM( 'N', TRANA, N, N, N, ONE, X, LDX, A, LDA, ZERO, + $ WORK( IXMA+1 ), N ) +* +* Estimate sepd(op(A),transpose(op(A))) +* + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +* + EST = ZERO + KASE = 0 + 10 CONTINUE + CALL DLACON( N*(N+1)/2, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +* +* Unpack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 30 J = 1, N + DO 20 I = J, N + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 20 CONTINUE + 30 CONTINUE + ELSE + DO 50 J = 1, N + DO 40 I = 1, J + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 40 CONTINUE + 50 CONTINUE + END IF +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, U, LDU, + $ ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK, N, ZERO, + $ WORK( ITMP+1 ), N ) + IF( KASE.EQ.1 ) THEN +* +* Solve op(A')*Y*op(A) - Y = scale2*RHS +* + CALL LYPDTR( TRANA, N, T, LDT, WORK( ITMP+1 ), N, SCALE2, + $ WORK( IWR+1 ), INFO2 ) + ELSE +* +* Solve op(A)*Z*op(A') - Z = scale2*RHS +* + CALL LYPDTR( TRANAT, N, T, LDT, WORK( ITMP+1 ), N, SCALE2, + $ WORK( IWR+1 ), INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, U, LDU, + $ ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) +* +* Pack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 70 J = 1, N + DO 60 I = J, N + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 60 CONTINUE + 70 CONTINUE + ELSE + DO 90 J = 1, N + DO 80 I = 1, J + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 80 CONTINUE + 90 CONTINUE + END IF + GO TO 10 + END IF +* + SEPD = SCALE2 / TWO / EST +* +* Return if the equation is singular +* + IF( SEPD.EQ.ZERO ) THEN + RCOND = ZERO + RETURN + END IF +* +* Estimate norm(Theta) +* + EST = ZERO + KASE = 0 + 100 CONTINUE + CALL DLACON( N*N, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +* +* Compute RHS = op(W')*X*op(A) + op(A')*X*op(W) +* + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, WORK, N, WORK( IXMA+1 ), + $ N, ZERO, WORK( ITMP+1 ), N ) + CALL DLACPY( UPLO, N, N, WORK( ITMP+1 ), N, WORK, N ) +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK( ITMP+1 ), + $ N, ZERO, WORK, N ) + IF( KASE.EQ.1 ) THEN +* +* Solve op(A')*Y*op(A) - Y = scale2*RHS +* + CALL LYPDTR( TRANA, N, T, LDT, WORK, N, SCALE2, + $ WORK( IWR+1 ), INFO2 ) + ELSE +* +* Solve op(A)*Z*op(A') - Z = scale2*RHS +* + CALL LYPDTR( TRANAT, N, T, LDT, WORK, N, SCALE2, + $ WORK( IWR+1 ), INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK( ITMP+1 ), N, U, + $ LDU, ZERO, WORK, N ) + GO TO 100 + END IF +* + THNORM = EST / SCALE2 +* +* Estimate the reciprocal condition number +* + RCOND = SEPD*XNORM / ( CNORM*SCALE + SEPD*( THNORM*ANORM ) ) + IF( RCOND.GT.ONE ) RCOND = ONE +* + WORK( 1 ) = DBLE( LWA ) + RETURN +* +* End of LYPDRC +* + END + SUBROUTINE LYPDSL( FACT, TRANA, N, A, LDA, UPLO, C, LDC, T, LDT, + $ U, LDU, WR, WI, X, LDX, SCALE, RCOND, FERR, + $ WORK, LWORK, IWORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER FACT, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDX, LWORK, N + DOUBLE PRECISION FERR, RCOND, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), T( LDT, * ), + $ U( LDU, * ), WI( * ), WORK( * ), WR( * ), + $ X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* LYPDSL solves the discrete-time matrix Lyapunov equation +* +* transpose(op(A))*X*op(A) - X = scale*C +* +* where op(A) = A or A**T and C is symmetric (C = C**T). 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 <= 1 to avoid overflow in X. +* +* Error bound on the solution and condition estimate are also provided. +* +* Arguments +* ========= +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the real Schur factorization +* of the matrix A is supplied on entry: +* = 'F': On entry, T 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 T and U. +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of C is stored; +* = 'L': Lower triangle of C is stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N) +* +* T (input or output) DOUBLE PRECISION array, dimension (LDT,N) +* If FACT = 'F', then T is an input argument and on entry +* contains the upper quasi-triangular matrix in Schur canonical +* form from the Schur factorization of A. +* If FACT = 'N', then T is an output argument and on exit +* returns the upper quasi-triangular matrix in Schur +* canonical form from the Schur factorization of A. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= 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 +* contains the orthogonal matrix U from the real Schur +* factorization of A. +* If FACT = 'N', then U is an output argument and on exit +* returns the orthogonal N-by-N matrix from the real Schur +* factorization of A. +* +* LDU (input) INTEGER +* The leading dimension of the array U. LDU >= max(1,N) +* +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) +* On exit, if FACT = 'N', WR(1:N) and WI(1:N) contain the +* real and imaginary parts, respectively, of the eigenvalues +* of A. +* If FACT = 'F', WR and WI are not referenced. +* +* X (output) DOUBLE PRECISION array, dimension (LDX,N) +* If INFO = 0, the N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N) +* +* SCALE (output) DOUBLE PRECISION +* The scale factor, scale, set <= 1 to avoid overflow in X. +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number +* of the discrete-time Lyapunov equation. +* +* FERR (output) DOUBLE PRECISION +* On exit, 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* LWORK >= 7*N*N + 2*N + max(1,3*N). +* For good performance, LWORK must generally be larger. +* +* IWORK (workspace) INTEGER array, dimension (N*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: the matrix A cannot be reduced to Schur canonical form +* = 2: A has almost reciprocal eigenvalues; perturbed +* values were used to solve the equation (but the +* matrix A is unchanged). +* +* Further Details +* =============== +* +* The discrete-time matrix Lyapunov equation is solved by the Barraud- +* Kitagawa algorithm [1], [2]. +* +* The condition number of the equation is estimated using 1-norm +* condition estimator. +* +* The forward error bound is estimated using the practical error bound +* proposed in [3]. +* +* References +* ========== +* +* T +* [1] A.Y. Barraud. A numerical algorithm to solve A XA - X = Q. +* IEEE Trans. Automat. Control, vol. AC-22, pp. 883-885, 1977. +* [2] G. Kitagawa. An algorithm for solving the matrix equation X = +* T +* FXF + S. Internat. J. Control, vol. 25, pp. 745-753, 1977. +* [3] N.J. Higham, Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, 1993, pp. 124-136. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOFACT, NOTRNA, VOIDDUMMY + INTEGER INFO2, LWA, LWAMAX, MINWRK, SDIM + DOUBLE PRECISION CNORM +* .. +* .. Local Arrays .. + LOGICAL BWORK( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DLACPY, DLASET, DSYMM, LYPDFR, + $ LYPDRC, LYPDTR, XERBLA, VOIDDUMMY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + INFO = 0 + IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. + $ LSAME( TRANA, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF +* +* Compute workspace +* + MINWRK = 7*N*N + 2*N + MAX( 1, 3*N ) + IF( LWORK.LT.MINWRK ) THEN + INFO = -21 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'LYPDSL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + IF( CNORM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution +* + CALL DLASET( 'F', N, N, ZERO, ZERO, X, LDX ) + SCALE = ONE + RCOND = ZERO + FERR = ZERO + RETURN + END IF +* + LWA = 0 +* + IF( NOFACT ) THEN +* +* Compute the Schur factorization of A +* + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + CALL DGEES( 'V', 'N', VOIDDUMMY, N, T, LDT, SDIM, + $ WR, WI, U, LDU, + $ WORK, LWORK, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWA = INT( WORK( 1 ) ) + END IF + LWAMAX = LWA +* +* Transform the right-hand side: C := U'*C*U. +* Form TEMP = C*U then X = U'*TEMP +* + CALL DSYMM( 'L', UPLO, N, N, ONE, C, LDC, U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK, N, ZERO, X, + $ LDX ) +* +* Solve the quasi-triangular discrete-time Lyapunov equation. +* The answer overwrites the right-hand side +* + CALL LYPDTR( TRANA, N, T, LDT, X, LDX, SCALE, WORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + END IF +* +* Transform back to obtain the solution: X := U*X*U'. +* Form TEMP = U*X then X = TEMP*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, X, LDX, U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, U, LDU, ZERO, X, + $ LDX ) +* +* Estimate the reciprocal of the condition number +* + CALL LYPDRC( 'F', TRANA, N, A, LDA, UPLO, C, LDC, T, LDT, U, LDU, + $ X, LDX, SCALE, RCOND, WORK, LWORK, IWORK, INFO2 ) +* +* Return if the equation is singular +* + IF( RCOND.EQ.ZERO ) THEN + FERR = ONE + RETURN + END IF + LWA = INT( WORK( 1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Estimate the bound on the forward error +* + CALL LYPDFR( TRANA, N, A, LDA, UPLO, C, LDC, T, LDT, U, LDU, + $ X, LDX, SCALE, FERR, WORK, LWORK, IWORK, INFO2 ) + LWA = 7*N*N + 2*N + LWAMAX = MAX( LWA, LWAMAX ) +* + WORK( 1 ) = DBLE( LWAMAX ) + RETURN +* +* End of LYPDSL +* + END + SUBROUTINE LYPDTR( TRANA, N, A, LDA, C, LDC, SCALE, WORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA + INTEGER INFO, LDA, LDC, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), WORK( N, * ) +* .. +* +* Purpose +* ======= +* +* LYPDTR solves the discrete-time matrix Lyapunov equation +* +* transpose(op(A))*X*op(A) - X = scale*C +* +* where op(A) = A or A**T, A is upper quasi-triangular and C is +* symmetric (C = C**T). 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 <= 1 to avoid overflow in X. +* +* A must be in Schur canonical form (as returned by 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. +* +* Arguments +* ========= +* +* TRANA (input) CHARACTER*1 +* Specifies the option op(A): +* = 'N': op(A) = A (No transpose) +* = 'T': op(A) = A**T (Transpose) +* = 'C': op(A) = A**H (Conjugate transpose = Transpose) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices X and C. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The upper quasi-triangular matrix A, in Schur canonical form. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the symmetric N-by-N right hand side matrix C. +* On exit, C is overwritten by the solution matrix X. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N) +* +* SCALE (output) DOUBLE PRECISION +* The scale factor, scale, set <= 1 to avoid overflow in X. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N,2) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: A has almost reciprocal eigenvalues; perturbed +* values were used to solve the equation (but the +* matrix A is unchanged). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRNA + INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT + DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, + $ SCALOC, SMIN, SMLNUM, SUML, SUMR, XNORM +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLANGE + EXTERNAL LSAME, DDOT, DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, DLALD2, DLASD2, DSCAL, DSYMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) +* + 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 + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'LYPDTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( N*N ) / EPS + BIGNUM = ONE / SMLNUM +* + SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', N, N, A, LDA, DUM ) ) +* + SCALE = ONE +* + IF( NOTRNA ) THEN +* +* Solve A'*X*A - X = scale*C. +* +* The (K,L)th block of X is determined starting from +* upper-left corner column by column by +* +* A(K,K)'*X(K,L)*A(L,L) - X(K,L) = C(K,L) - R(K,L) +* +* where +* +* K L-1 +* R(K,L) = SUM {A(I,K)'*SUM [X(I,J)*A(J,L)]} + +* I=1 J=1 +* +* K-1 +* {SUM [A(I,K)'*X(I,L)]}*A(L,L) +* I=1 +* +* Start column loop (index = L) +* L1 (L2): column index of the first (last) row of X(K,L) +* + LNEXT = 1 + DO 60 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 60 + IF( L.EQ.N ) THEN + L1 = L + L2 = L + ELSE + IF( A( L+1, L ).NE.ZERO ) THEN + L1 = L + L2 = L + 1 + LNEXT = L + 2 + ELSE + L1 = L + L2 = L + LNEXT = L + 1 + END IF + END IF +* +* Start row loop (index = K) +* K1 (K2): row index of the first (last) row of X(K,L) +* + CALL DSCAL( L1, ZERO, WORK( 1, 1 ), 1 ) + CALL DSCAL( L1, ZERO, WORK( 1, 2 ), 1 ) + CALL DSYMV( 'L', L1-1, ONE, C, LDC, A( 1, L1 ), 1, + $ ZERO, WORK( 1, 1 ), 1 ) + CALL DSYMV( 'L', L1-1, ONE, C, LDC, A( 1, L2 ), 1, + $ ZERO, WORK( 1, 2 ), 1 ) +* + KNEXT = L + DO 50 K = L, N + IF( K.LT.KNEXT ) + $ GO TO 50 + IF( K.EQ.N ) THEN + K1 = K + K2 = K + ELSE + IF( A( K+1, K ).NE.ZERO ) THEN + K1 = K + K2 = K + 1 + KNEXT = K + 2 + ELSE + K1 = K + K2 = K + KNEXT = K + 1 + END IF + END IF +* + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + WORK( K1, 1 ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ A( 1, L1 ), 1 ) + P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) +* + SUML = DDOT( K1, A( 1, K1 ), 1, WORK( 1, 1 ), 1 ) + SUMR = P11*A( L1, L1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) + SCALOC = ONE +* + 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 +* + IF( SCALOC.NE.ONE ) THEN + DO 10 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE + CALL DSCAL( N, SCALOC, WORK( 1, 1 ), 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 +* + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +* + WORK( K1, 1 ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ A( 1, L1 ), 1 ) + WORK( K2, 1 ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ A( 1, L1 ), 1 ) + P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) +* + SUML = DDOT( K2, A( 1, K1 ), 1, WORK( 1, 1 ), 1 ) + SUMR = P11*A( L1, L1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( K2, A( 1, K2 ), 1, WORK( 1, 1 ), 1 ) + SUMR = P21*A( L1, L1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SUMR ) +* + CALL DLASD2( .TRUE., .FALSE., 1, 2, 1, A( K1, K1 ), + $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, + $ X, 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 20 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 20 CONTINUE + CALL DSCAL( N, SCALOC, WORK( 1, 1 ), 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 ) +* + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +* + WORK( K1, 1 ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ A( 1, L1 ), 1 ) + WORK( K1, 2 ) = 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 ) +* + SUML = DDOT( K1, A( 1, K1 ), 1, WORK( 1, 1 ), 1 ) + SUMR = P11*A( L1, L1 ) + P12*A( L2, L1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( K1, A( 1, K1 ), 1, WORK( 1, 2 ), 1 ) + SUMR = P11*A( L1, L2 ) + P12*A( L2, L2 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SUMR ) +* + CALL DLASD2( .TRUE., .FALSE., 1, 1, 2, A( K1, K1 ), + $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, + $ X, 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 30 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE + CALL DSCAL( N, SCALOC, WORK( 1, 1 ), 1 ) + CALL DSCAL( N, SCALOC, WORK( 1, 2 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 1, 2 ) +* + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +* + WORK( K1, 1 ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ A( 1, L1 ), 1 ) + WORK( K2, 1 ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ A( 1, L1 ), 1 ) + WORK( K1, 2 ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ A( 1, L2 ), 1 ) + WORK( K2, 2 ) = 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 ) +* + SUML = DDOT( K2, A( 1, K1 ), 1, WORK( 1, 1 ), 1 ) + SUMR = P11*A( L1, L1 ) + P12*A( L2, L1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( K2, A( 1, K1 ), 1, WORK( 1, 2 ), 1 ) + SUMR = P11*A( L1, L2 ) + P12*A( L2, L2 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SUMR ) +* + SUML = DDOT( K2, A( 1, K2 ), 1, WORK( 1, 1 ), 1 ) + SUMR = P21*A( L1, L1 ) + P22*A( L2, L1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( K2, A( 1, K2 ), 1, WORK( 1, 2 ), 1 ) + SUMR = P21*A( L1, L2 ) + P22*A( L2, L2 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SUMR ) +* + IF( K1.EQ.L1 ) THEN + CALL DLALD2( .FALSE., A( K1, K1 ), LDA, VEC, 2, + $ SCALOC, X, 2, XNORM, IERR ) + ELSE + CALL DLASD2( .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 +* + IF( SCALOC.NE.ONE ) THEN + DO 40 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 40 CONTINUE + CALL DSCAL( N, SCALOC, WORK( 1, 1 ), 1 ) + CALL DSCAL( N, SCALOC, WORK( 1, 2 ), 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 +* + 50 CONTINUE + 60 CONTINUE +* + ELSE +* +* Solve A*X*A' - X = scale*C. +* +* The (K,L)th block of X is determined starting from +* bottom-right corner column by column by +* +* A(K,K)*X(K,L)*A(L,L)' = C(K,L) - R(K,L) +* +* where +* +* N N +* R(K,L) = SUM {A(K,I)* SUM [X(I,J)*A(L,J)']} + +* I=K J=L+1 +* +* N +* { SUM [A(K,J)*X(J,L)]}*A(L,L)' +* J=K+1 +* +* Start column loop (index = L) +* L1 (L2): column index of the first (last) row of X(K,L) +* + LNEXT = N + DO 120 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 120 + IF( L.EQ.1 ) THEN + L1 = L + L2 = L + ELSE + IF( A( L, L-1 ).NE.ZERO ) THEN + L1 = L - 1 + L2 = L + LNEXT = L - 2 + ELSE + L1 = L + L2 = L + LNEXT = L - 1 + END IF + END IF +* +* Start row loop (index = K) +* K1 (K2): row index of the first (last) row of X(K,L) +* + CALL DSCAL( N-L1+1, ZERO, WORK( L1, 1 ), 1 ) + CALL DSCAL( N-L1+1, ZERO, WORK( L1, 2 ), 1 ) + CALL DSYMV( 'U', N-L2, ONE, C( L2+1, L2+1 ), LDC, + $ A( L1, L2+1 ), LDA, ZERO, + $ WORK( L2+1, 1 ), 1 ) + CALL DSYMV( 'U', N-L2, ONE, C( L2+1, L2+1 ), LDC, + $ A( L2, L2+1 ), LDA, ZERO, + $ WORK( L2+1, 2 ), 1 ) +* + KNEXT = L + DO 110 K = L, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 110 + IF( K.EQ.1 ) THEN + K1 = K + K2 = K + ELSE + IF( A( K, K-1 ).NE.ZERO ) THEN + K1 = K - 1 + K2 = K + KNEXT = K - 2 + ELSE + K1 = K + K2 = K + KNEXT = K - 1 + END IF + END IF +* + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + WORK( K1, 1 ) = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), + $ LDC, A( L1, MIN( L1+1, N ) ), LDA ) + P11 = DDOT( N-K1, A( K1, MIN( K1+1, N ) ), LDA, + $ C( MIN( K1+1, N ), L1 ), 1 ) +* + SUML = DDOT( N-K1+1, A( K1, K1 ), LDA, + $ WORK( K1, 1 ), 1 ) + SUMR = P11*A( L1, L1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) + SCALOC = ONE +* + 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 +* + IF( SCALOC.NE.ONE ) THEN + DO 70 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE + CALL DSCAL( N, SCALOC, WORK( 1, 1 ), 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 +* + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +* + WORK( K1, 1 ) = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), + $ LDC, A( L1, MIN( L1+1, N ) ), LDA ) + WORK( K2, 1 ) = DDOT( N-L1, C( K2, MIN( L1+1, N ) ), + $ LDC, A( L1, MIN( L1+1, N ) ), LDA ) + P11 = DDOT( N-K2, A( K1, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L1 ), 1 ) + P21 = DDOT( N-K2, A( K2, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L1 ), 1 ) +* + SUML = DDOT( N-K1+1, A( K1, K1 ), LDA, + $ WORK( K1, 1 ), 1 ) + SUMR = P11*A( L1, L1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( N-K1+1, A( K2, K1 ), LDA, + $ WORK( K1, 1 ), 1 ) + SUMR = P21*A( L1, L1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SUMR ) +* + CALL DLASD2( .FALSE., .TRUE., 1, 2, 1, A( K1, K1 ), + $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, + $ X, 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 80 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 80 CONTINUE + CALL DSCAL( N, SCALOC, WORK( 1, 1 ), 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 ) +* + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +* + WORK( K1, 1 ) = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), + $ LDC, A( L1, MIN( L2+1, N ) ), LDA ) + WORK( K1, 2 ) = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), + $ LDC, A( L2, MIN( L2+1, N ) ), LDA ) + P11 = DDOT( N-K1, A( K1, MIN( K1+1, N ) ), LDA, + $ C( MIN( K1+1, N ), L1 ), 1 ) + P12 = DDOT( N-K1, A( K1, MIN( K1+1, N ) ), LDA, + $ C( MIN( K1+1, N ), L2 ), 1 ) +* + SUML = DDOT( N-K1+1, A( K1, K1 ), LDA, + $ WORK( K1, 1 ), 1 ) + SUMR = P11*A( L1, L1 ) + P12*A( L1, L2 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( N-K1+1, A( K1, K1 ), LDA, + $ WORK( K1, 2 ), 1 ) + SUMR = P11*A( L2, L1 ) + P12*A( L2, L2 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SUMR ) +* + CALL DLASD2( .FALSE., .TRUE., 1, 1, 2, A( K1, K1 ), + $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, + $ X, 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +* + IF( SCALOC.NE.ONE ) THEN + DO 90 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 90 CONTINUE + CALL DSCAL( N, SCALOC, WORK( 1, 1 ), 1 ) + CALL DSCAL( N, SCALOC, WORK( 1, 2 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 1, 2 ) +* + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +* + WORK( K1, 1 ) = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), + $ LDC, A( L1, MIN( L2+1, N ) ), LDA ) + WORK( K2, 1 ) = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), + $ LDC, A( L1, MIN( L2+1, N ) ), LDA ) + WORK( K1, 2 ) = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), + $ LDC, A( L2, MIN( L2+1, N ) ), LDA ) + WORK( K2, 2 ) = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), + $ LDC, A( L2, MIN( L2+1, N ) ), LDA ) + P11 = DDOT( N-K2, A( K1, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L1 ), 1 ) + P12 = DDOT( N-K2, A( K1, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L2 ), 1 ) + P21 = DDOT( N-K2, A( K2, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L1 ), 1 ) + P22 = DDOT( N-K2, A( K2, MIN( K2+1, N ) ), LDA, + $ C( MIN( K2+1, N ), L2 ), 1 ) +* + SUML = DDOT( N-K1+1, A( K1, K1 ), LDA, + $ WORK( K1, 1 ), 1 ) + SUMR = P11*A( L1, L1 ) + P12*A( L1, L2 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( N-K1+1, A( K1, K1 ), LDA, + $ WORK( K1, 2 ), 1 ) + SUMR = P11*A( L2, L1 ) + P12*A( L2, L2 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SUMR ) +* + SUML = DDOT( N-K1+1, A( K2, K1 ), LDA, + $ WORK( K1, 1 ), 1 ) + SUMR = P21*A( L1, L1 ) + P22*A( L1, L2 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SUMR ) +* + SUML = DDOT( N-K1+1, A( K2, K1 ), LDA, + $ WORK( K1, 2 ), 1 ) + SUMR = P21*A( L2, L1 ) + P22*A( L2, L2 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SUMR ) +* + IF( K1.EQ.L1 ) THEN + CALL DLALD2( .TRUE., A( K1, K1 ), LDA, VEC, 2, + $ SCALOC, X, 2, XNORM, IERR ) + ELSE + CALL DLASD2( .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 +* + IF( SCALOC.NE.ONE ) THEN + DO 100 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE + CALL DSCAL( N, SCALOC, WORK( 1, 1 ), 1 ) + CALL DSCAL( N, SCALOC, WORK( 1, 2 ), 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 +* + 110 CONTINUE + 120 CONTINUE +* + END IF +* + RETURN +* +* End of LYPDTR +* + END + SUBROUTINE RICCFR( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ T, LDT, U, LDU, FERR, WORK, LWORK, IWORK, + $ INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDC, LDD, LDT, LDU, LDX, LWORK, N + DOUBLE PRECISION FERR +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), D( LDD, * ), + $ T( LDT, * ), U( LDU, * ), WORK( * ), + $ X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* RICCFR estimates the forward error bound for the computed solution of +* the matrix algebraic Riccati equation +* +* transpose(op(A))*X + X*op(A) + C - X*D*X = 0 +* +* where op(A) = A or A**T and C, D are symmetric (C = C**T, D = D**T). +* The matrices A, C, D and X are N-by-N. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C, D and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangles of C and D are stored; +* = 'L': Lower triangles of C and D are stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N). +* +* D (input) DOUBLE PRECISION array, dimension (LDD,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of D +* contains the upper triangular part of the matrix D. +* If UPLO = 'L', the leading N-by-N lower triangular part of D +* contains the lower triangular part of the matrix D. +* +* LDD (input) INTEGER +* The leading dimension of the array D. LDD >= max(1,N). +* +* X (input) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* T (input) DOUBLE PRECISION array, dimension (LDT,N) +* The upper quasi-triangular matrix in Schur canonical form +* from the Schur factorization of the matrix Ac = A - D*X +* (if TRANA = 'N') or Ac = A - X*D (if TRANA = 'T' or 'C'). +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max(1,N) +* +* U (input) DOUBLE PRECISION array, dimension (LDU,N) +* The orthogonal N-by-N matrix from the real Schur +* factorization of the matrix Ac = A - D*X (if TRANA = 'N') +* or Ac = A - X*D (if TRANA = 'T' or 'C'). +* +* LDU (input) INTEGER +* The leading dimension of the array U. LDU >= max(1,N) +* +* FERR (output) DOUBLE PRECISION +* 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* +* LWORK INTEGER +* The dimension of the array WORK. LWORK >= 7*N*N +* +* IWORK (workspace) INTEGER array, dimension (N*N) +* +* INFO INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further details +* =============== +* +* The forward error bound is estimated using a practical error bound +* similar to the one proposed in [1]. +* +* References +* ========== +* +* [1] N.J. Higham. Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* [2] P.Hr. Petkov, M.M. Konstantinov, and V. Mehrmann. 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. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA + CHARACTER TRANAT + INTEGER I, IABS, IDBS, IDLC, IJ, INFO2, IRES, ITMP, + $ IXBS, J, KASE, MINWRK + DOUBLE PRECISION EPS, EST, SCALE, XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACON, DLACPY, DSYMM, DSYR2K, LYPCTR, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDD.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF +* +* Get the machine precision +* + EPS = DLAMCH( 'Epsilon' ) +* +* Compute workspace +* + MINWRK = 7*N*N + IF( LWORK.LT.MINWRK ) THEN + INFO = -18 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'RICCFR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + XNORM = DLANSY( '1', UPLO, N, X, LDX, WORK ) + IF( XNORM.EQ.ZERO ) THEN + FERR = ZERO + RETURN + END IF +* +* Workspace usage +* + IDLC = N*N + ITMP = IDLC + N*N + IABS = ITMP + N*N + IDBS = IABS + N*N + IXBS = IDBS + N*N + IRES = IXBS + N*N +* + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +* +* Form residual matrix R = transpose(op(A))*X + X*op(A) + C - X*D*X +* + CALL DLACPY( UPLO, N, N, C, LDC, WORK( IRES+1 ), N ) + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, ONE, + $ WORK( IRES+1 ), N ) + CALL DSYMM( 'R', UPLO, N, N, ONE, D, LDD, X, LDX, ZERO, + $ WORK( ITMP+1 ), N ) + CALL DSYMM( 'R', UPLO, N, N, -ONE, X, LDX, WORK( ITMP+1 ), N, ONE, + $ WORK( IRES+1 ), N ) +* +* Add to abs(R) a term that takes account of rounding errors in +* forming R: +* abs(R) := abs(R) + EPS*(4*abs(C) + (n+4)*(abs(op(A'))*abs(X) + +* abs(X)*abs(op(A))) + 2*(n+1)*abs(X)*abs(D)*abs(X)) +* where EPS is the machine precision +* + IJ = 0 + DO 20 J = 1, N + DO 10 I = 1, N + IJ = IJ + 1 + WORK( IABS+IJ ) = ABS( A( I, J ) ) + WORK( IXBS+IJ ) = ABS( X( I, J ) ) + 10 CONTINUE + 20 CONTINUE + IF( LOWER ) THEN + DO 40 J = 1, N + DO 30 I = J, N + WORK( ITMP+I+(J-1)*N ) = ABS( C( I, J ) ) + WORK( IDBS+I+(J-1)*N ) = ABS( D( I, J ) ) + 30 CONTINUE + 40 CONTINUE + ELSE + DO 60 J = 1, N + DO 50 I = 1, J + WORK( ITMP+I+(J-1)*N ) = ABS( C( I, J ) ) + WORK( IDBS+I+(J-1)*N ) = ABS( D( I, J ) ) + 50 CONTINUE + 60 CONTINUE + END IF + CALL DSYR2K( UPLO, TRANAT, N, N, DBLE( N+4 )*EPS, WORK( IABS+1 ), + $ N, WORK( IXBS+1 ), N, FOUR*EPS, WORK( ITMP+1 ), N ) + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( IDBS+1 ), N, + $ WORK( IXBS+1 ), N, ZERO, WORK( IDLC+1 ), N ) + CALL DSYMM( 'R', UPLO, N, N, DBLE( 2*N+2 )*EPS, WORK( IXBS+1 ), N, + $ WORK( IDLC+1 ), N, ONE, WORK( ITMP+1 ), N ) + IF( LOWER ) THEN + DO 80 J = 1, N + DO 70 I = J, N + WORK( IRES+I+(J-1)*N ) = ABS( WORK( IRES+I+(J-1)*N ) ) + + $ WORK( ITMP+I+(J-1)*N ) + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 J = 1, N + DO 90 I = 1, J + WORK( IRES+I+(J-1)*N ) = ABS( WORK( IRES+I+(J-1)*N ) ) + + $ WORK( ITMP+I+(J-1)*N ) + 90 CONTINUE + 100 CONTINUE + END IF +* +* Compute forward error bound, using matrix norm estimator +* + EST = ZERO + KASE = 0 + 110 CONTINUE + CALL DLACON( N*(N+1)/2, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IJ = 0 + IF( LOWER ) THEN + DO 130 J = 1, N + DO 120 I = J, N + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Scale by the residual matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ )* + $ WORK( IRES+I+(J-1)*N ) + ELSE +* +* Unpack the lower triangular part of symmetric +* matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 150 J = 1, N + DO 140 I = 1, J + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Scale by the residual matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ )* + $ WORK( IRES+I+(J-1)*N ) + ELSE +* +* Unpack the upper triangular part of symmetric +* matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + END IF + 140 CONTINUE + 150 CONTINUE + END IF +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, + $ WORK, N, ZERO, WORK( ITMP+1 ), N ) + IF( KASE.EQ.2 ) THEN +* +* Solve op(A')*Y + Y*op(A) = scale*RHS +* + CALL LYPCTR( TRANA, N, T, LDT, WORK( ITMP+1 ), N, + $ SCALE, INFO2 ) + ELSE +* +* Solve op(A)*Z + Z*op(A') = scale*RHS +* + CALL LYPCTR( TRANAT, N, T, LDT, WORK( ITMP+1 ), N, + $ SCALE, INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, + $ U, LDU, ZERO, WORK( ITMP+1 ), N ) + IJ = 0 + IF( LOWER ) THEN + DO 170 J = 1, N + DO 160 I = J, N + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Pack the lower triangular part of symmetric +* matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + ELSE +* +* Scale by the residual matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N )* + $ WORK( IRES+I+(J-1)*N ) + END IF + 160 CONTINUE + 170 CONTINUE + ELSE + DO 190 J = 1, N + DO 180 I = 1, J + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Pack the upper triangular part of symmetric +* matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + ELSE +* +* Scale by the residual matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N )* + $ WORK( IRES+I+(J-1)*N ) + END IF + 180 CONTINUE + 190 CONTINUE + END IF + GO TO 110 + END IF +* +* Compute the estimate of the forward error +* + FERR = TWO*EST / DLANSY( 'Max', UPLO, N, X, LDX, WORK ) / SCALE + IF( FERR.GT.ONE ) FERR = ONE +* + RETURN +* +* End of RICCFR +* + END + SUBROUTINE RICCMF( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ WR, WI, RCOND, FERR, WORK, LWORK, IWORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDC, LDD, LDX, LWORK, N + DOUBLE PRECISION FERR, RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), D( LDD, * ), + $ X( LDX, * ), WI( * ), WORK( * ), WR( * ) +* .. +* +* Purpose +* ======= +* +* RICCMF solves the matrix algebraic Riccati equation +* +* transpose(op(A))*X + X*op(A) + C - X*D*X = 0 +* +* where op(A) = A or A**T and C, D are symmetric (C = C**T, D = D**T). +* The matrices A, C and D are N-by-N and the solution X is N-by-N. +* +* Error bound on the solution and a condition estimate are also +* provided. +* +* It is assumed that the matrices A, C and D are such that the +* corresponding Hamiltonian matrix has N eigenvalues with negative +* real parts. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C, D and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangles of C and D are stored; +* = 'L': Lower triangles of C and D are stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N). +* +* D (input) DOUBLE PRECISION array, dimension (LDD,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of D +* contains the upper triangular part of the matrix D. +* If UPLO = 'L', the leading N-by-N lower triangular part of D +* contains the lower triangular part of the matrix D. +* +* LDD (input) INTEGER +* The leading dimension of the array D. LDD >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) +* On exit, if INFO = 0, WR(1:N) and WI(1:N) contain the real +* and imaginary parts, respectively, of the eigenvalues of +* Ac = A - D*X (if TRANA = 'N') or Ac = A - X*D (if TRANA = 'T' +* or 'C'). +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number of +* the Riccati equation. +* +* FERR (output) DOUBLE PRECISION +* On exit, 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= 28*N*N + 2*N + +* max(1,2*N). +* For optimum performance LWORK >= 28*N*N + 2*N + ( 2*N+1 )*NB, +* where NB is the optimal blocksize. +* +* IWORK (workspace) INTEGER array, dimension max(2*N,N*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: the iteration for the spectral decomposition failed to +* converge after 50 iterations, but an approximate +* solution and error bounds have been computed +* = 2: the system of linear equations for the solution is +* singular to working precision +* = 3: the matrix A-D*X (or A-X*D) can not be reduced to Schur +* canonical form and condition number estimate and +* forward error estimate are not computed +* +* Further Details +* =============== +* +* The matrix Riccati equation is solved by the inverse free method +* proposed in [1]. +* +* The condition number of the equation is estimated using 1-norm +* estimator. +* +* The forward error bound is estimated using a practical error bound +* similar to the one proposed in [2]. +* +* References +* ========== +* +* [1] Z. Bai and Q. Qian. Inverse free parallel method for the +* numerical solution of algebraic Riccati equations. In J.G. Lewis, +* editor, Proc. Fifth SIAM Conf. on Appl. Lin. Algebra, Snowbird, +* UT, June 1994, pp. 167-171. SIAM, Philadelphia, PA, 1994. +* [2] N.J. Higham. Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* [3] P.Hr. Petkov, M.M. Konstantinov, and V. Mehrmann. 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. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 50 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA + CHARACTER EQUED + INTEGER I, IA, IAF, IB, IBR, IC, IFR, IJ, IJ1, IJ2, + $ INFO2, IQ, IR, IS, ISCL, ITAU, ITER, IU, IV, + $ IWRK, J, LWA, LWA0, LWAMAX, MINWRK, N2, N4 + DOUBLE PRECISION CNORM, CNORM2, DNORM, DNORM2, EPS, RDNORM, + $ RNORM, TEMP, TOL +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEMM, DGEQP3, DGEQRF, DGERQF, DLACPY, + $ DLASET, DORMQR, DORMRQ, DGESVX, DLASCL, DSCAL, + $ RICCFR, RICCRC, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDD.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF +* +* Set tol +* + EPS = DLAMCH( 'Epsilon' ) + TOL = 10.0D+0*DBLE(N)*EPS +* +* Compute workspace +* + MINWRK = 28*N*N + 2*N + MAX( 1, 2*N ) + IF( LWORK.LT.MINWRK ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'RICCMF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Compute the norms of the matrices C and D +* + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + DNORM = DLANSY( '1', UPLO, N, D, LDD, WORK ) +* + N2 = 2*N + N4 = 4*N +* +* Construct the Hamiltonian matrix +* + DO 20 J = 1, N + DO 10 I = 1, N + IJ = ( J - 1 )*N2 + I + IF( NOTRNA ) THEN + WORK( IJ ) = A( I, J ) + ELSE + WORK( IJ ) = A( J, I ) + END IF + IJ = ( J - 1 )*N2 + N + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) THEN + WORK( IJ ) = -C( I, J ) + ELSE + WORK( IJ ) = -C( J, I ) + END IF + ELSE + IF( I.GE.J ) THEN + WORK( IJ ) = -C( I, J ) + ELSE + WORK( IJ ) = -C( J, I ) + END IF + END IF + IJ = ( N + J - 1 )*N2 + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) THEN + WORK( IJ ) = -D( I, J ) + ELSE + WORK( IJ ) = -D( J, I ) + END IF + ELSE + IF( I.GE.J ) THEN + WORK( IJ ) = -D( I, J ) + ELSE + WORK( IJ ) = -D( J, I ) + END IF + END IF + IJ = ( N + J - 1)*N2 + N + I + IF( NOTRNA ) THEN + WORK( IJ ) = -A( J, I ) + ELSE + WORK( IJ ) = -A( I, J ) + END IF + 10 CONTINUE + 20 CONTINUE +* +* Scale the Hamiltonian matrix +* + CNORM2 = SQRT( CNORM ) + DNORM2 = SQRT( DNORM ) + ISCL = 0 + IF( CNORM2.GT.DNORM2 .AND. DNORM2.GT.ZERO ) THEN + CALL DLASCL( 'G', 0, 0, CNORM2, DNORM2, N, N, WORK( N+1 ), N2, + $ INFO2 ) + CALL DLASCL( 'G', 0, 0, DNORM2, CNORM2, N, N, WORK( N2*N+1 ), + $ N2, INFO2 ) + ISCL = 1 + END IF +* +* Workspace usage +* + LWA0 = 28*N*N + 2*N + LWAMAX = 0 + IA = N2*N2 + IR = IA + N2*N2 + IS = IR + N4*N2 + IQ = IS + N2*N2 + ITAU = IQ + N4*N2 + IWRK = ITAU + N2 +* +* Compute B0 and -A0 +* + DO 40 J = 1, N2 + DO 30 I = 1, N2 + IJ1 = ( J - 1 )*N2 + I + IJ2 = IA + ( J - 1 )*N2 + I + TEMP = WORK( IJ1 ) + IF( I.EQ.J ) THEN + WORK( IJ1 ) = ONE + TEMP + WORK( IJ2 ) = -ONE + TEMP + ELSE + WORK( IJ2 ) = TEMP + END IF + 30 CONTINUE + 40 CONTINUE + CALL DLACPY( 'F', N2, N2, WORK, N2, WORK( IR+1 ), N4 ) + CALL DLACPY( 'F', N2, N2, WORK( IA+1 ), N2, WORK( IR+N2+1 ), N4 ) +* +* Main iteration loop +* + DO 80 ITER = 1, MAXIT +* +* [ Bj] +* QR decomposition of [ ] +* [-Aj] +* + CALL DGEQRF( N4, N2, WORK( IR+1 ), N4, WORK( ITAU+1 ), + $ WORK( IWRK+1 ), LWORK-IWRK, INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Make the diagonal elements of Rj positive +* + DO 50 I = 1, N2 + IF( WORK( IR+(I-1)*N4+I ).LT.ZERO ) + $ CALL DSCAL( N2-I+1, -ONE, WORK( IR+(I-1)*N4+I ), N4 ) + 50 CONTINUE + IF( ITER.GT.1 ) THEN +* +* Compute Rj+1 - Rj +* + DO 70 J = 1, N2 + DO 60 I = 1, J + IJ1 = IR + ( J - 1 )*N4 + I + IJ2 = IS + ( J - 1 )*N2 + I + WORK( IJ2 ) = WORK( IJ1 ) - WORK( IJ2 ) + 60 CONTINUE + 70 CONTINUE + RDNORM = DLANGE( '1', N2, N2, WORK( IS+1 ), N2, + $ WORK( IWRK+1 )) + END IF +* +* Save Rj for future use +* + CALL DLACPY( 'U', N2, N2, WORK( IR+1 ), N4, WORK( IS+1 ), N2 ) + IF( ITER.EQ.1 ) + $ CALL DLASET( 'L', N2-1, N2-1, ZERO, ZERO, WORK( IS+2 ), N2 ) +* +* Generate the matrices Q12 and Q22 +* + CALL DLASET( 'F', N2, N2, ZERO, ZERO, WORK( IQ+1 ), N4 ) + CALL DLASET( 'F', N2, N2, ZERO, ONE, WORK( IQ+N2+1 ), N4 ) + CALL DORMQR( 'L', 'N', N4, N2, N2, WORK( IR+1 ), N4, + $ WORK( ITAU+1 ), WORK( IQ+1 ), N4, WORK( IWRK+1 ), + $ LWORK-IWRK, INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Compute Bj and -Aj +* + CALL DGEMM( 'T', 'N', N2, N2, N2, ONE, WORK( IQ+N2+1 ), + $ N4, WORK, N2, ZERO, WORK( IR+1 ), N4 ) + CALL DGEMM( 'T', 'N', N2, N2, N2, ONE, WORK( IQ+1 ), N4, + $ WORK( IA+1 ), N2, ZERO, WORK( IR+N2+1 ), N4 ) + CALL DLACPY( 'F', N2, N2, WORK( IR+1 ), N4, WORK, N2 ) + CALL DLACPY( 'F', N2, N2, WORK( IR+N2+1 ), N4, WORK( IA+1 ), + $ N2 ) +* +* Test for convergence +* + IF( ITER.GT.1 .AND. RDNORM.LE.TOL*RNORM ) GO TO 90 + RNORM = DLANGE( '1', N2, N2, WORK( IS+1 ), N2, + $ WORK( IWRK+1 )) + 80 CONTINUE + INFO = 1 + 90 LWA0 = 10*N*N + 2*N + IQ = IA + N2*N2 + ITAU = IQ + N2*N + IWRK = ITAU + N2 +* +* Compute Ap + Bp +* + CALL DSCAL( N2*N2, -ONE, WORK( IA+1 ), 1 ) + CALL DAXPY( N2*N2, ONE, WORK( IA+1 ), 1, WORK, 1 ) +* +* QR decomposition with column pivoting of Ap +* + DO 100 J = 1, N2 + IWORK( J ) = 0 + 100 CONTINUE + CALL DGEQP3( N2, N2, WORK( IA+1 ), N2, IWORK, WORK( ITAU+1 ), + $ WORK( IWRK+1 ), LWORK-IWRK, INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* T +* Compute Q1 (Ap + Bp) +* + CALL DORMQR( 'L', 'T', N2, N2, N2, WORK( IA+1 ), N2, + $ WORK( ITAU+1 ), WORK, N2, WORK( IWRK+1 ), LWORK-IWRK, + $ INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* T +* RQ decomposition of Q1 (Ap + Bp) +* + CALL DGERQF( N2, N2, WORK, N2, WORK( ITAU+1 ), WORK( IWRK+1 ), + $ LWORK-IWRK, INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Generate Q11 and Q21 +* + CALL DLASET( 'F', N, N, ZERO, ONE, WORK( IQ+1 ), N2 ) + CALL DLASET( 'F', N, N, ZERO, ZERO, WORK( IQ+N+1 ), N2 ) + CALL DORMRQ( 'L', 'T', N2, N, N2, WORK, N2, WORK( ITAU+1 ), + $ WORK( IQ+1 ), N2, WORK( IWRK+1 ), LWORK-IWRK, INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Store the matrices Q11 and Q21 +* + DO 120 J = 1, N + DO 110 I = 1, N + IJ = ( J - 1 )*N + I + IV = IQ + ( I - 1 )*N2 + J + WORK( IJ ) = WORK( IV ) + IJ = ( J - 1 )*N + 2*N*N + I + IV = IQ + ( I - 1 )*N2 + N + J + WORK( IJ ) = WORK( IV ) + 110 CONTINUE + 120 CONTINUE +* +* Workspace usage +* + IAF = N*N + IB = IAF + N*N + IR = IB + N*N + IC = IR + N + IFR = IC + N + IBR = IFR + N + IWRK = IBR + N +* +* Compute the solution matrix X +* + CALL DGESVX( 'E', 'N', N, N, WORK, N, WORK( IAF+1 ), N, + $ IWORK, EQUED, WORK( IR+1 ), WORK( IC+1 ), + $ WORK( IB+1 ), N, X, LDX, RCOND, WORK( IFR+1 ), + $ WORK( IBR+1 ), WORK( IWRK+1 ), IWORK( N+1 ), + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +* +* Symmetrize the solution +* + IF( N.GT.1 ) THEN + DO 140 I = 1, N - 1 + DO 130 J = I + 1, N + TEMP = ( X( I, J ) + X( J, I ) ) / TWO + X( I, J ) = TEMP + X( J, I ) = TEMP + 130 CONTINUE + 140 CONTINUE + END IF +* +* Undo scaling for the solution matrix +* + IF( ISCL.EQ.1 ) + $ CALL DLASCL( 'G', 0, 0, DNORM2, CNORM2, N, N, X, LDX, INFO2 ) +* +* Workspace usage +* + LWA = 2*N*N + IU = N*N + IWRK = IU + N*N +* +* Estimate the reciprocal condition number +* + CALL RICCRC( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ RCOND, WORK, N, WORK( IU+1 ), N, WR, WI, + $ WORK( IWRK+1 ), LWORK-IWRK, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF + LWA = LWA + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Return if the equation is singular +* + IF( RCOND.EQ.ZERO ) THEN + FERR = ONE + WORK( 1 ) = DBLE( LWAMAX ) + RETURN + END IF +* +* Estimate the bound on the forward error +* + CALL RICCFR( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ WORK, N, WORK( IU+1 ), N, FERR, WORK( IWRK+1 ), + $ LWORK-IWRK, IWORK, INFO2 ) + LWA = 9*N*N + LWAMAX = MAX( LWA, LWAMAX ) + WORK( 1 ) = DBLE( LWAMAX ) + RETURN +* +* End of RICCMF +* + END + SUBROUTINE RICCMS( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ WR, WI, RCOND, FERR, WORK, LWORK, IWORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDC, LDD, LDX, LWORK, N + DOUBLE PRECISION FERR, RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), D( LDD, * ), + $ X( LDX, * ), WI( * ), WORK( * ), WR( * ) +* .. +* +* Purpose +* ======= +* +* RICCMS solves the matrix algebraic Riccati equation +* +* transpose(op(A))*X + X*op(A) + C - X*D*X = 0 +* +* where op(A) = A or A**T and C, D are symmetric (C = C**T, D = D**T). +* The matrices A, C and D are N-by-N and the solution X is N-by-N. +* +* Error bound on the solution and a condition estimate are also +* provided. +* +* It is assumed that the matrices A, C and D are such that the +* corresponding Hamiltonian matrix has N eigenvalues with negative +* real parts. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C, D and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangles of C and D are stored; +* = 'L': Lower triangles of C and D are stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N). +* +* D (input) DOUBLE PRECISION array, dimension (LDD,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of D +* contains the upper triangular part of the matrix D. +* If UPLO = 'L', the leading N-by-N lower triangular part of D +* contains the lower triangular part of the matrix D. +* +* LDD (input) INTEGER +* The leading dimension of the array D. LDD >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,N) +* On exit, if INFO = 0, the N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) +* On exit, if INFO = 0, WR(1:N) and WI(1:N) contain the real +* and imaginary parts, respectively, of the eigenvalues of +* Ac = A - D*X (if TRANA = 'N') or Ac = A - X*D (if TRANA = 'T' +* or 'C'). +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number of +* the Riccati equation. +* +* FERR (output) DOUBLE PRECISION +* On exit, 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= 9*N*N + 7*N + 1. +* For optimum performance LWORK >= 9*N*N + 5*N + ( 2*N+1 )*NB, +* where NB is the optimal blocksize. +* +* IWORK (workspace) INTEGER array, dimension max(2*N,N*N) +* +* INFO (output) 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 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-D*X (or A-X*D) can not be reduced to Schur +* canonical form and condition number estimate and +* forward error estimate have not been computed. +* +* Further Details +* =============== +* +* The Riccati equation is solved by the matrix sign function approach +* [1], [2] implementing a scaling which enhances the numerical +* stability [4]. +* +* The condition number of the equation is estimated using 1-norm +* condition estimator. +* +* The forward error bound is estimated using a practical error bound +* similar to the one proposed in [3]. +* +* References +* ========== +* +* [1] Z. Bai, J. Demmel, J. Dongarra, A. Petitet, H. Robinson, and +* K. Stanley. The spectral decomposition of nonsymmetric matrices +* on distributed memory parallel computers. SIAM J. Sci. Comput., +* vol. 18, pp. 1446-1461, 1997. +* [2] R. Byers, C. He, and V. Mehrmann. The matrix sign function method +* and the computation of invariant subspaces. SIAM J. Matrix Anal. +* Appl., vol. 18, pp. 615-632, 1997. +* [3] N.J. Higham. Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* [4] P.Hr. Petkov, M.M. Konstantinov, and V. Mehrmann. 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. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 50 ) + DOUBLE PRECISION ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA + CHARACTER EQUED + INTEGER I, IAF, IB, IBR, IC, IFR, IJ, IJ1, IJ2, INFO2, + $ IR, ISCL, ITAU, ITER, IU, IV, IVS, IWRK, J, JI, + $ LWA, LWAMAX, MINWRK, N2 + DOUBLE PRECISION CNORM, CNORM2, CONV, DNORM, DNORM2, EPS, HNORM, + $ HINNRM, SCALE, TEMP, TOL +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEQP3, DGESVX, DLASCL, DLASET, + $ DORMQR, DSCAL, DSYTRF, DSYTRI, RICCFR, RICCRC, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDD.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF +* +* Set tol +* + EPS = DLAMCH( 'Epsilon' ) + TOL = 10.0D+0*DBLE(N)*EPS +* +* Compute workspace +* + MINWRK = 9*N*N + 7*N + 1 + IF( LWORK.LT.MINWRK ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'RICCMS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Compute the norms of the matrices C and D +* + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + DNORM = DLANSY( '1', UPLO, N, D, LDD, WORK ) +* + N2 = 2*N +* +* Construct the block-permuted Hamiltonian matrix +* + DO 20 J = 1, N + DO 10 I = 1, N + IF( .NOT.LOWER ) THEN + IJ = (N + J - 1 )*N2 + I + IF( NOTRNA ) THEN + WORK( IJ ) = -A( J, I ) + ELSE + WORK( IJ ) = -A( I, J ) + END IF + ELSE + IJ = ( J - 1 )*N2 + N + I + IF( NOTRNA ) THEN + WORK( IJ ) = -A( I, J ) + ELSE + WORK( IJ ) = -A( J, I ) + END IF + END IF + IJ = ( J - 1 )*N2 + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) WORK( IJ ) = -C( I, J ) + ELSE + IF( I.GE.J ) WORK( IJ ) = -C( I, J ) + END IF + IJ = ( N + J - 1 )*N2 + N + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) WORK( IJ ) = D( I, J ) + ELSE + IF( I.GE.J ) WORK( IJ ) = D( I, J ) + END IF + 10 CONTINUE + 20 CONTINUE +* +* Block-scaling +* + CNORM2 = SQRT( CNORM ) + DNORM2 = SQRT( DNORM ) + ISCL = 0 + IF( CNORM2.GT.DNORM2 .AND. DNORM2.GT.ZERO ) THEN + CALL DLASCL( UPLO, 0, 0, CNORM2, DNORM2, N, N, WORK, N2, + $ INFO2 ) + CALL DLASCL( UPLO, 0, 0, DNORM2, CNORM2, N, N, + $ WORK( N2*N+N+1 ), N2, INFO2 ) + ISCL = 1 + END IF +* +* Workspace usage +* + IVS = N2*N2 + ITAU = IVS + N2*N2 + IWRK = ITAU + N2 +* +* Compute the matrix sign function +* + CALL DCOPY( N2*N2, WORK, 1, WORK( IVS+1 ), 1 ) + LWAMAX = 0 +* + DO 50 ITER = 1, MAXIT +* +* Store the norm of the Hamiltonian matrix +* + HNORM = DLANSY( 'F', UPLO, N2, WORK, N2, WORK ) +* +* Compute the inverse of the block-permuted Hamiltonian matrix +* + CALL DSYTRF( UPLO, N2, WORK( IVS+1 ), N2, IWORK, + $ WORK( IWRK+1 ), LWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWA = INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) + CALL DSYTRI( UPLO, N2, WORK( IVS+1 ), N2, IWORK, + $ WORK( IWRK+1 ), INFO2 ) +* +* Block-permutation of the inverse matrix +* + DO 40 J = 1, N + DO 30 I = 1, N + IJ1 = IVS + ( J - 1 )*N2 + I + IJ2 = IVS + ( N + J - 1 )*N2 + N + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) THEN + TEMP = WORK( IJ1 ) + WORK( IJ1 ) = -WORK( IJ2 ) + WORK( IJ2 ) = -TEMP + END IF + ELSE + IF( I.GE.J ) THEN + TEMP = WORK( IJ1 ) + WORK( IJ1 ) = -WORK( IJ2 ) + WORK( IJ2 ) = -TEMP + END IF + END IF + IF( .NOT.LOWER ) THEN + IF( I.LT.J ) THEN + IJ1 = IVS + ( N + J - 1 )*N2 + I + IJ2 = IVS + ( N + I - 1 )*N2 + J + TEMP = WORK( IJ1 ) + WORK( IJ1 ) = WORK( IJ2 ) + WORK( IJ2 ) = TEMP + END IF + ELSE + IF( I.GT.J ) THEN + IJ1 = IVS + ( J - 1 )*N2 + N + I + IJ2 = IVS + ( I - 1 )*N2 + N + J + TEMP = WORK( IJ1 ) + WORK( IJ1 ) = WORK( IJ2 ) + WORK( IJ2 ) = TEMP + END IF + END IF + 30 CONTINUE + 40 CONTINUE +* +* Scale the Hamiltonian matrix and its inverse +* + HINNRM = DLANSY( 'F', UPLO, N2, WORK( IVS+1 ), N2, WORK ) + SCALE = SQRT( HINNRM/HNORM ) + CALL DSCAL( N2*N2, ONE/SCALE, WORK( IVS+1 ), 1 ) +* +* Compute the next iteration +* + CALL DAXPY( N2*N2, SCALE, WORK, 1, WORK( IVS+1 ), 1 ) + CALL DSCAL( N2*N2, HALF, WORK( IVS+1 ), 1 ) + CALL DAXPY( N2*N2, -ONE, WORK( IVS+1 ), 1, WORK, 1 ) +* +* Test for convergence +* + CONV = DLANSY( 'F', UPLO, N2, WORK, N2, WORK ) + IF( CONV.LE.TOL*HNORM ) GO TO 60 + CALL DCOPY( N2*N2, WORK( IVS+1 ), 1, WORK, 1 ) + 50 CONTINUE + IF( CONV.GT.TOL*HNORM ) THEN + INFO = 2 + END IF + 60 DO 80 J = 1, N2 + DO 70 I = 1, N2 + IJ = IVS + ( J - 1 )*N2 + I + JI = IVS + ( I - 1 )*N2 + J + IF( .NOT.LOWER ) THEN + IF( I.LT.J ) WORK( JI ) = WORK( IJ ) + ELSE + IF( I.GT.J ) WORK( JI ) = WORK( IJ ) + END IF + 70 CONTINUE + 80 CONTINUE +* +* Back block-permutation +* + DO 100 J = 1, N + DO 90 I = 1, N + IJ1 = IVS + ( J - 1 )*N2 + I + IJ2 = IVS + ( J - 1 )*N2 + N + I + TEMP = WORK( IJ1 ) + WORK( IJ1 ) = -WORK( IJ2 ) + WORK( IJ2 ) = TEMP + IJ1 = IVS + ( N + J - 1 )*N2 + I + IJ2 = IVS + ( N + J - 1 )*N2 + N + I + TEMP = WORK( IJ1 ) + WORK( IJ1 ) = -WORK( IJ2 ) + WORK( IJ2 ) = TEMP + 90 CONTINUE + 100 CONTINUE +* +* Compute the QR decomposition of the projector onto the stable +* invariant subspace +* + CALL DLASET( 'F', N2, N2, ZERO, ONE, WORK, N2 ) + CALL DAXPY( N2*N2, -ONE, WORK( IVS+1 ), 1, WORK, 1 ) + CALL DSCAL( N2*N2, HALF, WORK, 1 ) + DO 110 I = 1, N2 + IWORK( I ) = 0 + 110 CONTINUE + CALL DGEQP3( N2, N2, WORK, N2, IWORK, WORK( ITAU+1 ), + $ WORK( IWRK+1 ), LWORK-IWRK, INFO2 ) + LWA = INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Accumulate the orthogonal transformations +* + CALL DLASET( 'F', N2, N, ZERO, ONE, WORK( IVS+1 ), N2 ) + CALL DORMQR( 'L', 'N', N2, N, N, WORK, N2, WORK( ITAU+1 ), + $ WORK( IVS+1 ), N2, WORK( IWRK+1 ), LWORK-IWRK, + $ INFO2 ) + LWA = INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Store the matrices V11 and V21 +* + DO 130 J = 1, N + DO 120 I = 1, N + IJ = ( J - 1 )*N + I + IV = ( I - 1 )*N2 + IVS + J + WORK( IJ ) = WORK( IV ) + IJ = ( J - 1 )*N + 2*N*N + I + IV = ( I - 1 )*N2 + IVS + N + J + WORK( IJ ) = WORK( IV ) + 120 CONTINUE + 130 CONTINUE +* +* Workspace usage +* + IAF = N*N + IB = IAF + N*N + IR = IB + N*N + IC = IR + N + IFR = IC + N + IBR = IFR + N + IWRK = IBR + N +* +* Compute the solution matrix X +* + CALL DGESVX( 'E', 'N', N, N, WORK, N, WORK( IAF+1 ), N, + $ IWORK, EQUED, WORK( IR+1 ), WORK( IC+1 ), + $ WORK( IB+1 ), N, X, LDX, RCOND, WORK( IFR+1 ), + $ WORK( IBR+1 ), WORK( IWRK+1 ), IWORK( N+1 ), + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF +* +* Symmetrize the solution +* + IF( N.GT.1 ) THEN + DO 150 I = 1, N - 1 + DO 140 J = I + 1, N + TEMP = ( X( I, J ) + X( J, I ) ) / TWO + X( I, J ) = TEMP + X( J, I ) = TEMP + 140 CONTINUE + 150 CONTINUE + END IF +* +* Undo scaling for the solution matrix +* + IF( ISCL.EQ.1 ) + $ CALL DLASCL( 'G', 0, 0, DNORM2, CNORM2, N, N, X, LDX, INFO2 ) +* +* Workspace usage +* + LWA = 2*N*N + IU = N*N + IWRK = IU + N*N +* +* Estimate the reciprocal condition number +* + CALL RICCRC( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ RCOND, WORK, N, WORK( IU+1 ), N, WR, WI, + $ WORK( IWRK+1 ), LWORK-IWRK, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = LWA + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Return if the equation is singular +* + IF( RCOND.EQ.ZERO ) THEN + FERR = ONE + WORK( 1 ) = DBLE( LWAMAX ) + RETURN + END IF +* +* Estimate the bound on the forward error +* + CALL RICCFR( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ WORK, N, WORK( IU+1 ), N, FERR, WORK( IWRK+1 ), + $ LWORK-IWRK, IWORK, INFO2 ) + LWA = 9*N*N + LWAMAX = MAX( LWA, LWAMAX ) + WORK( 1 ) = DBLE( LWAMAX ) + RETURN +* +* End of RICCMS +* + END + SUBROUTINE RICCRC( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ RCOND, T, LDT, U, LDU, WR, WI, WORK, LWORK, + $ IWORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDC, LDD, LDT, LDU, LDX, LWORK, N + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), D( LDD, * ), + $ T( LDT, * ), U( LDU, * ), WI( * ), WORK( * ), + $ WR( * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* RICCRC estimates the reciprocal of the condition number of the matrix +* algebraic Riccati equation +* +* transpose(op(A))*X + X*op(A) + C - X*D*X = 0 +* +* where op(A) = A or A**T and C, D are symmetric (C = C**T, D = D**T). +* The matrices A, C, D and X are N-by-N. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C, D and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangles of C and D are stored; +* = 'L': Lower triangles of C and D are stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N). +* +* D (input) DOUBLE PRECISION array, dimension (LDD,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of D +* contains the upper triangular part of the matrix D. +* If UPLO = 'L', the leading N-by-N lower triangular part of D +* contains the lower triangular part of the matrix D. +* +* LDD (input) INTEGER +* The leading dimension of the array D. LDD >= max(1,N). +* +* X (input) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number +* of the Riccati equation. +* If X = 0, RCOND is set to zero. +* +* T (output) DOUBLE PRECISION array, dimension (LDT,N) +* The upper quasi-triangular matrix in Schur canonical form +* from the Schur factorization of the matrix Ac = A - D*X +* (if TRANA = 'N') or Ac = A - X*D (if TRANA = 'T' or 'C'). +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max(1,N) +* +* U (output) DOUBLE PRECISION array, dimension (LDU,N) +* The orthogonal N-by-N matrix from the real Schur +* factorization of the matrix Ac = A - D*X (if TRANA = 'N') +* or Ac = A - X*D (if TRANA = 'T' or 'C'). +* +* LDU (input) INTEGER +* The leading dimension of the array U. LDU >= max(1,N) +* +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) +* On exit, WR(1:N) and WI(1:N) contain the real and imaginary +* parts, respectively, of the eigenvalues of Ac = A - D*X (if +* TRANA = 'N') or Ac = A - X*D (if TRANA = 'T' or 'C'). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK INTEGER +* The dimension of the array WORK. LWORK >= 3*N*N + max(1,3*N). +* For good performance, LWORK must generally be larger. +* +* IWORK (workspace) INTEGER array, dimension (N*N) +* +* INFO INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: the matrix Ac can not be reduced to Schur canonical +* form and condition number estimate is not computed +* +* Further details +* =============== +* +* The condition number of the Riccati equation is estimated as +* +* cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(C) + +* norm(Pi)*norm(D) ) / norm(X) +* +* where Omega, Theta and Pi are linear operators defined by +* +* Omega(Z) = transpose(op(Ac))*Z + Z*op(Ac), +* Theta(Z) = inv(Omega(transpose(op(Z))*X + X*op(Z))), +* Pi(Z) = inv(Omega(X*Z*X)) +* +* and Ac = A - D*X (if TRANA = 'N') or Ac = A - X*D (if TRANA = 'T' or +* 'C'). +* +* The program estimates the quantities +* +* sep(op(Ac),-transpose(op(Ac)) = 1 / norm(inv(Omega)), +* +* norm(Theta) and norm(Pi) using 1-norm condition estimator. +* +* References +* ========== +* +* [1] A.R. Ghavimi and A.J. Laub. Backward error, sensitivity, and +* refinment of computed solutions of algebraic Riccati equations. +* Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, +* 1995. +* [2] P.Hr. Petkov, M.M. Konstantinov, and V. Mehrmann. 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. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA, VOIDDUMMY + CHARACTER TRANAT + INTEGER I, IDLC, IJ, INFO2, ITMP, IWRK, J, KASE, LWA, + $ MINWRK, SDIM + DOUBLE PRECISION ANORM, CNORM, DNORM, EST, PINORM, SCALE, SEP, + $ THNORM, XNORM +* .. +* .. Local Arrays .. + LOGICAL BWORK( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANGE, DLANSY + EXTERNAL DLANGE, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DLACON, DLACPY, DSYMM, DSYR2K, + $ LYPCTR, XERBLA, VOIDDUMMY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDD.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF +* +* Compute workspace +* + MINWRK = 3*N*N + MAX( 1, 3*N ) + IF( LWORK.LT.MINWRK ) THEN + INFO = -20 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'RICCRC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + XNORM = DLANSY( '1', UPLO, N, X, LDX, WORK ) + IF( XNORM.EQ.ZERO ) THEN + RCOND = ZERO + RETURN + END IF +* +* Compute the norms of the matrices A, C and D +* + ANORM = DLANGE( '1', N, N, A, LDA, WORK ) + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + DNORM = DLANSY( '1', UPLO, N, D, LDD, WORK ) +* +* Workspace usage +* + LWA = 3*N*N + IDLC = N*N + ITMP = IDLC + N*N + IWRK = ITMP + N*N +* + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + IF( NOTRNA ) THEN +* +* Compute Ac = A - D*X +* + CALL DSYMM( 'L', UPLO, N, N, -ONE, D, LDD, X, LDX, ONE, + $ T, LDT ) + ELSE +* +* Compute Ac = A - X*D +* + CALL DSYMM( 'R', UPLO, N, N, -ONE, D, LDD, X, LDX, ONE, + $ T, LDT ) + END IF +* +* Compute the Schur factorization of Ac +* + CALL DGEES( 'V', 'N', VOIDDUMMY, N, T, LDT, SDIM, + $ WR, WI, U, LDU, + $ WORK( IWRK+1 ), LWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWA = LWA + INT( WORK( IWRK+1 ) ) +* +* Estimate sep(op(Ac),-transpose(Ac)) +* + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +* + EST = ZERO + KASE = 0 + 10 CONTINUE + CALL DLACON( N*(N+1)/2, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +* +* Unpack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 30 J = 1, N + DO 20 I = J, N + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 20 CONTINUE + 30 CONTINUE + ELSE + DO 50 J = 1, N + DO 40 I = 1, J + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 40 CONTINUE + 50 CONTINUE + END IF +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK, N, + $ ZERO, WORK( ITMP+1 ), N ) + IF( KASE.EQ.1 ) THEN +* +* Solve op(A')*Y + Y*op(A) = scale*RHS +* + CALL LYPCTR( TRANA, N, T, LDT, WORK( ITMP+1 ), N, + $ SCALE, INFO2 ) + ELSE +* +* Solve op(A)*Z + Z*op(A') = scale*RHS +* + CALL LYPCTR( TRANAT, N, T, LDT, WORK( ITMP+1 ), N, + $ SCALE, INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, U, LDU, + $ ZERO, WORK( ITMP+1 ), N ) +* +* Pack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 70 J = 1, N + DO 60 I = J, N + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 60 CONTINUE + 70 CONTINUE + ELSE + DO 90 J = 1, N + DO 80 I = 1, J + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 80 CONTINUE + 90 CONTINUE + END IF + GO TO 10 + END IF +* + SEP = SCALE / TWO / EST +* +* Return if the equation is singular +* + IF( SEP.EQ.ZERO ) THEN + RCOND = ZERO + RETURN + END IF +* +* Estimate norm(Theta) +* + EST = ZERO + KASE = 0 + 100 CONTINUE + CALL DLACON( N*N, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +* +* Compute RHS = op(W')*X + X*op(W) +* + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, WORK, N, X, LDX, ZERO, + $ WORK( ITMP+1 ), N ) + CALL DLACPY( UPLO, N, N, WORK( ITMP+1 ), N, WORK, N ) +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK, N, U, LDU, + $ ZERO, WORK( ITMP+1 ), N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, + $ WORK( ITMP+1 ), N, ZERO, WORK, N ) + IF( KASE.EQ.1 ) THEN +* +* Solve op(Ac')*Y + Y*op(Ac) = scale*RHS +* + CALL LYPCTR( TRANA, N, T, LDT, WORK, N, SCALE, + $ INFO2 ) + ELSE +* +* Solve op(Ac)*Z + Z*op(Ac') = scale*RHS +* + CALL LYPCTR( TRANAT, N, T, LDT, WORK, N, SCALE, + $ INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK, N, U, LDU, + $ ZERO, WORK( ITMP+1 ), N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + GO TO 100 + END IF +* + THNORM = EST / SCALE +* +* Estimate norm(Pi) +* + EST = ZERO + KASE = 0 + 110 CONTINUE + CALL DLACON( N*(N+1)/2, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +* +* Unpack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 130 J = 1, N + DO 120 I = J, N + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 120 CONTINUE + 130 CONTINUE + ELSE + DO 150 J = 1, N + DO 140 I = 1, J + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 140 CONTINUE + 150 CONTINUE + END IF +* +* Compute RHS = X*W*X +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, X, LDX, + $ ZERO, WORK, N ) + CALL DSYMM( 'R', UPLO, N, N, ONE, X, LDX, WORK, N, ZERO, + $ WORK( ITMP+1 ), N ) +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, + $ WORK, N, ZERO, WORK( ITMP+1 ), N ) + IF( KASE.EQ.1 ) THEN +* +* Solve op(Ac')*Y + Y*op(Ac) = scale*RHS +* + CALL LYPCTR( TRANA, N, T, LDT, WORK( ITMP+1 ), N, + $ SCALE, INFO2 ) + ELSE +* +* Solve op(Ac)*Z + Z*op(Ac') = scale*RHS +* + CALL LYPCTR( TRANAT, N, T, LDT, WORK( ITMP+1 ), N, + $ SCALE, INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' . +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, + $ U, LDU, ZERO, WORK( ITMP+1 ), N ) +* +* Pack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 170 J = 1, N + DO 160 I = J, N + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 160 CONTINUE + 170 CONTINUE + ELSE + DO 190 J = 1, N + DO 180 I = 1, J + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 180 CONTINUE + 190 CONTINUE + END IF + GO TO 110 + END IF +* + PINORM = TWO*EST / SCALE +* +* Estimate the reciprocal condition number +* + RCOND = SEP*XNORM / ( CNORM + SEP*( THNORM*ANORM + + $ PINORM*DNORM ) ) + IF( RCOND.GT.ONE ) RCOND = ONE +* + WORK( 1 ) = DBLE( LWA ) + RETURN +* +* End of RICCRC +* + END + SUBROUTINE RICCSL( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ WR, WI, RCOND, FERR, WORK, LWORK, IWORK, BWORK, + $ INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDC, LDD, LDX, LWORK, N + DOUBLE PRECISION FERR, RCOND +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), D( LDD, * ), + $ X( LDX, * ), WI( * ), WORK( * ), WR( * ) +* .. +* +* Purpose +* ======= +* +* RICCSL solves the matrix algebraic Riccati equation +* +* transpose(op(A))*X + X*op(A) + C - X*D*X = 0 +* +* where op(A) = A or A**T and C, D are symmetric (C = C**T, D = D**T). +* The matrices A, C and D are N-by-N and the solution X is N-by-N. +* +* Error bound on the solution and a condition estimate are also +* provided. +* +* It is assumed that the matrices A, C and D are such that the +* corresponding Hamiltonian matrix has N eigenvalues with negative +* real parts. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C, D and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangles of C and D are stored; +* = 'L': Lower triangles of C and D are stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N). +* +* D (input) DOUBLE PRECISION array, dimension (LDD,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of D +* contains the upper triangular part of the matrix D. +* If UPLO = 'L', the leading N-by-N lower triangular part of D +* contains the lower triangular part of the matrix D. +* +* LDD (input) INTEGER +* The leading dimension of the array D. LDD >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) +* On exit, if INFO = 0, WR(1:N) and WI(1:N) contain the real +* and imaginary parts, respectively, of the eigenvalues of +* Ac = A - D*X (if TRANA = 'N') or Ac = A - X*D (if TRANA = 'T' +* or 'C'). +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number of +* the Riccati equation. +* +* FERR (output) DOUBLE PRECISION +* On exit, 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= 9*N*N + 4*N + +* max(1,6*N). +* For good performance, LWORK must generally be larger. +* +* IWORK (workspace) INTEGER array, dimension max(2*N,N*N) +* +* BWORK (workspace) LOGICAL array, dimension (2*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: the QR algorithm failed to compute the eigenvalues of +* the Hamiltonian matrix +* = 2: the eigenvalues of the Hamiltonian matrix could not be +* reordered because some eigenvalues were too close to +* separate +* = 3: after reordering, roundoff changed values of some +* complex eigenvalues so that leading eigenvalues in +* the Schur form have no longer negative real parts +* = 4: the Hamiltonian matrix has less than N eigenvalues +* with negative real parts +* = 5: the system of linear equations for the solution is +* singular to working precision +* = 6: the matrix A-D*X (or A-X*D) can not be reduced to Schur +* canonical form and condition number estimate and +* forward error estimate are not computed +* +* Further Details +* =============== +* +* The matrix Riccati equation is solved by the Schur method [1]. +* +* The condition number of the equation is estimated using 1-norm +* estimator. +* +* The forward error bound is estimated using a practical error bound +* similar to the one proposed in [3]. +* +* References +* ========== +* +* [1] A.J. Laub. A Schur method for solving algebraic Riccati +* equations. IEEE Trans. Autom. Control, vol. 24, pp. 913-921, +* 1979. +* [2] A.R. Ghavimi and A.J. Laub. Backward error, sensitivity, and +* refinment of computed solutions of algebraic Riccati equations. +* Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, +* 1995. +* [3] N.J. Higham. Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* [4] P.Hr. Petkov, M.M. Konstantinov, and V. Mehrmann. 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. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA + CHARACTER EQUED + INTEGER I, IAF, IB, IBR, IC, IFR, IJ, INFO2, IR, ISCL, + $ IU, IV, IVS, IWI, IWR, IWRK, J, LWA, LWAMAX, + $ MINWRK, N2, SDIM + DOUBLE PRECISION CNORM, CNORM2, DNORM, DNORM2, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME, SELNEG + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY, LSAME, SELNEG +* .. +* .. External Subroutines .. + EXTERNAL DGEES, DGESVX, DLASCL, RICCFR, RICCRC, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDD.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF +* +* Compute workspace +* + MINWRK = 9*N*N + 4*N + MAX( 1, 6*N ) + IF( LWORK.LT.MINWRK ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'RICCSL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Compute the norms of the matrices C and D +* + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + DNORM = DLANSY( '1', UPLO, N, D, LDD, WORK ) +* + N2 = 2*N +* +* Construct the Hamiltonian matrix +* + DO 20 J = 1, N + DO 10 I = 1, N + IJ = ( J - 1 )*N2 + I + IF( NOTRNA ) THEN + WORK( IJ ) = A( I, J ) + ELSE + WORK( IJ ) = A( J, I ) + END IF + IJ = ( J - 1 )*N2 + N + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) THEN + WORK( IJ ) = -C( I, J ) + ELSE + WORK( IJ ) = -C( J, I ) + END IF + ELSE + IF( I.GE.J ) THEN + WORK( IJ ) = -C( I, J ) + ELSE + WORK( IJ ) = -C( J, I ) + END IF + END IF + IJ = ( N + J - 1 )*N2 + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) THEN + WORK( IJ ) = -D( I, J ) + ELSE + WORK( IJ ) = -D( J, I ) + END IF + ELSE + IF( I.GE.J ) THEN + WORK( IJ ) = -D( I, J ) + ELSE + WORK( IJ ) = -D( J, I ) + END IF + END IF + IJ = ( N + J - 1)*N2 + N + I + IF( NOTRNA ) THEN + WORK( IJ ) = -A( J, I ) + ELSE + WORK( IJ ) = -A( I, J ) + END IF + 10 CONTINUE + 20 CONTINUE +* +* Scale the Hamiltonian matrix +* + CNORM2 = SQRT( CNORM ) + DNORM2 = SQRT( DNORM ) + ISCL = 0 + IF( CNORM2.GT.DNORM2 .AND. DNORM2.GT.ZERO ) THEN + CALL DLASCL( 'G', 0, 0, CNORM2, DNORM2, N, N, WORK( N+1 ), N2, + $ INFO2 ) + CALL DLASCL( 'G', 0, 0, DNORM2, CNORM2, N, N, WORK( N2*N+1 ), + $ N2, INFO2 ) + ISCL = 1 + END IF +* +* Workspace usage +* + LWA = 8*N*N + 4*N + IWR = N2*N2 + IWI = IWR + N2 + IVS = IWI + N2 + IWRK = IVS + N2*N2 +* +* Compute the Schur factorization of the Hamiltonian matrix +* + CALL DGEES( 'V', 'S', SELNEG, N2, WORK, N2, SDIM, + $ WORK( IWR+1 ), WORK( IWI+1 ), WORK( IVS+1 ), + $ N2, WORK( IWRK+1 ), LWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.GT.0 .AND. INFO2.LE.N2 ) THEN + INFO = 1 + RETURN + ELSE IF( INFO2.EQ.N2+1 ) THEN + INFO = 2 + RETURN + ELSE IF( INFO2.EQ.N2+2 ) THEN + INFO = 3 + RETURN + ELSE IF( SDIM.NE.N ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = LWA + INT( WORK( IWRK+1 ) ) +* +* Store the matrices V11 and V21 +* + DO 40 J = 1, N + DO 30 I = 1, N + IJ = ( J - 1 )*N + I + IV = ( I - 1 )*N2 + IVS + J + WORK( IJ ) = WORK( IV ) + IJ = ( J - 1 )*N + 2*N*N + I + IV = ( I - 1 )*N2 + IVS + N + J + WORK( IJ ) = WORK( IV ) + 30 CONTINUE + 40 CONTINUE +* +* Workspace usage +* + IAF = N*N + IB = IAF + N*N + IR = IB + N*N + IC = IR + N + IFR = IC + N + IBR = IFR + N + IWRK = IBR + N +* +* Compute the solution matrix X +* + CALL DGESVX( 'E', 'N', N, N, WORK, N, WORK( IAF+1 ), N, + $ IWORK, EQUED, WORK( IR+1 ), WORK( IC+1 ), + $ WORK( IB+1 ), N, X, LDX, RCOND, WORK( IFR+1 ), + $ WORK( IBR+1 ), WORK( IWRK+1 ), IWORK( N+1 ), + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF +* +* Symmetrize the solution +* + IF( N.GT.1 ) THEN + DO 60 I = 1, N - 1 + DO 50 J = I + 1, N + TEMP = ( X( I, J ) + X( J, I ) ) / TWO + X( I, J ) = TEMP + X( J, I ) = TEMP + 50 CONTINUE + 60 CONTINUE + END IF +* +* Undo scaling for the solution matrix +* + IF( ISCL.EQ.1 ) + $ CALL DLASCL( 'G', 0, 0, DNORM2, CNORM2, N, N, X, LDX, INFO2 ) +* +* Workspace usage +* + LWA = 2*N*N + IU = N*N + IWRK = IU + N*N +* +* Estimate the reciprocal condition number +* + CALL RICCRC( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ RCOND, WORK, N, WORK( IU+1 ), N, WR, WI, + $ WORK( IWRK+1 ), LWORK-IWRK, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LWA = LWA + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Return if the equation is singular +* + IF( RCOND.EQ.ZERO ) THEN + FERR = ONE + WORK( 1 ) = DBLE( LWAMAX ) + RETURN + END IF +* +* Estimate the bound on the forward error +* + CALL RICCFR( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ WORK, N, WORK( IU+1 ), N, FERR, WORK( IWRK+1 ), + $ LWORK-IWRK, IWORK, INFO2 ) + LWA = 9*N*N + LWAMAX = MAX( LWA, LWAMAX ) + WORK( 1 ) = DBLE( LWAMAX ) + RETURN +* +* End of RICCSL +* + END + + LOGICAL FUNCTION SELNEG( WR, WI ) +* +* -- LISPACK auxiliary routine (version 3.0) -- +* Tech. University of Sofia +* July 5, 1999 +* +* .. Scalar Arguments .. + DOUBLE PRECISION WR, WI +* .. +* +* Purpose +* ======= +* +* SELNEG is used to select eigenvalues with negative real parts +* to sort to the top left of the Schur form of the Hamiltonian +* matrix in solving matrix algebraic Riccati equations +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* + IF( WR.LT.ZERO ) THEN + SELNEG = .TRUE. + ELSE + SELNEG = .FALSE. + END IF +* +* End of SELNEG +* + END + SUBROUTINE RICDFR( TRANA, N, A, LDA, UPLO, C, LDC, X, LDX, AC, + $ LDAC, T, LDT, U, LDU, WFERR, FERR, WORK, LWORK, + $ IWORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDAC, LDC, LDT, LDU, LDX, LWORK, N + DOUBLE PRECISION FERR +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), C( LDC, * ), + $ T( LDT, * ), U( LDU, * ), WFERR( * ), + $ WORK( * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* RICDFR estimates the forward error bound for the computed solution of +* the discrete-time matrix algebraic Riccati equation +* -1 +* transpose(op(A))*X*(In + D*X) *op(A) - X + C = 0 +* +* where op(A) = A or A**T and C, D are symmetric (C = C**T, D = D**T). +* The matrices A, C, D and X are N-by-N. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C, D and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of C is stored; +* = 'L': Lower triangle of C is stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N). +* +* X (input) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDC >= max(1,N). +* +* AC (input) DOUBLE PRECISION array, dimension (LDAC,N) +* -1 +* The matrix Ac = (I + D*X) *A (if TRANA = 'N') or +* -1 +* Ac = A*(I + X*D) (if TRANA = 'T' or 'C'). +* +* LDAC (input) INTEGER +* The leading dimension of the array AC. LDAC >= max(1,N). +* +* T (input) DOUBLE PRECISION array, dimension (LDT,N) +* The upper quasi-triangular matrix in Schur canonical form +* from the Schur factorization of the matrix Ac. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max(1,N) +* +* U (input) DOUBLE PRECISION array, dimension (LDU,N) +* The orthogonal N-by-N matrix from the real Schur +* factorization of the matrix Ac. +* +* LDU (input) INTEGER +* The leading dimension of the array U. LDU >= max(1,N) +* +* WFERR (input) DOUBLE PRECISION array, dimension (N) +* The vector of estimated forward error bound for each column +* of the matrix Ac, as obtained by the subroutine RICDRC. +* +* FERR (output) DOUBLE PRECISION +* 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* +* LWORK INTEGER +* The dimension of the array WORK. LWORK >= 7*N*N + 2*N +* +* IWORK (workspace) INTEGER array, dimension (N*N) +* +* INFO INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further details +* =============== +* +* The forward error bound is estimated using a practical error bound +* similar to the one proposed in [1]. +* +* References +* ========== +* +* [1] N.J. Higham. Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA + CHARACTER TRANAT + INTEGER I, IABS, IDLC, IJ, INFO2, IRES, ITMP, IWRK, + $ IXBS, IXMA, J, KASE, MINWRK + DOUBLE PRECISION ACJMAX, EPS, EST, SCALE, XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACON, DSYMM, LYPDTR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDAC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF +* +* Get the machine precision +* + EPS = DLAMCH( 'Epsilon' ) +* +* Compute workspace +* + MINWRK = 7*N*N + 2*N + IF( LWORK.LT.MINWRK ) THEN + INFO = -19 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'RICDFR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + XNORM = DLANSY( '1', UPLO, N, X, LDX, WORK ) + IF( XNORM.EQ.ZERO ) THEN + FERR = ZERO + RETURN + END IF +* +* Workspace usage +* + IDLC = N*N + ITMP = IDLC + N*N + IXMA = ITMP + N*N + IABS = IXMA + N*N + IXBS = IABS + N*N + IRES = IXBS + N*N + IWRK = IRES + N*N +* + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +* +* Form residual matrix R = transpose(op(A))*X*op(Ac) + C - X +* + CALL DGEMM( TRANAT, 'N', N, N, N, ONE, A, LDA, X, LDX, ZERO, + $ WORK( IXMA+1 ), N ) + CALL DGEMM( 'N', TRANA, N, N, N, ONE, WORK( IXMA+1 ), N, + $ AC, LDAC, ZERO, WORK( ITMP+1 ), N ) + IF( LOWER ) THEN + DO 20 J = 1, N + DO 10 I = J, N + WORK( IRES+I+(J-1)*N ) = C( I, J ) - X( I, J ) + + $ WORK( ITMP+I+(J-1)*N ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = 1, J + WORK( IRES+I+(J-1)*N ) = C( I, J ) - X( I, J ) + + $ WORK( ITMP+I+(J-1)*N ) + 30 CONTINUE + 40 CONTINUE + END IF +* +* Add to abs(R) a term that takes account of rounding errors in +* forming R: +* abs(R) := abs(R) + EPS*( 4*abs(C) + 4*abs(X) + +* (2*n+3)*abs(op(A'))*abs(X)*abs(op(Ac) + +* 2*(n+1)*abs(op(A'))*abs(X)*abs(op(DAc) ) +* where EPS is the machine precision and DAc is a bound on the +* absolute error in computing the matrix Ac +* + DO 60 J = 1, N + DO 50 I = 1, N + IJ = I + ( J - 1 )*N + WORK( IABS+IJ ) = ABS( A( I, J ) ) + WORK( IXBS+IJ ) = ABS( X( I, J ) ) + WORK( IDLC+IJ ) = ABS( AC( I, J ) ) + 50 CONTINUE + 60 CONTINUE + CALL DGEMM( TRANAT, 'N', N, N, N, ONE, WORK( IABS+1 ), N, + $ WORK( IXBS+1 ), N, ZERO, WORK( IXMA+1 ), N ) + CALL DGEMM( 'N', TRANA, N, N, N, ONE, WORK( IXMA+1 ), N, + $ WORK( IDLC+1 ), N, ZERO, WORK( ITMP+1 ), N ) + DO 80 J = 1, N + ACJMAX = DLANGE( 'M', N, 1, AC( 1, J ), LDAC, WORK ) + DO 70 I = 1, N + WORK( IABS+I+(J-1)*N ) = ACJMAX*WFERR( J ) + 70 CONTINUE + 80 CONTINUE + CALL DGEMM( 'N', TRANA, N, N, N, ONE, WORK( IXMA+1 ), N, + $ WORK( IABS+1 ), N, ZERO, WORK( IDLC+1 ), N ) + IF( LOWER ) THEN + DO 100 J = 1, N + DO 90 I = J, N + WORK( IRES+I+(J-1)*N ) = ABS( WORK( IRES+I+(J-1)*N ) ) + + $ FOUR*EPS*( ABS( C( I, J ) ) + ABS( X( I, J ) ) ) + + $ DBLE( 2*N + 3 )*EPS*WORK( ITMP+I+(J-1)*N ) + + $ DBLE( 2*N + 2 )*WORK( IDLC+1 ) + 90 CONTINUE + 100 CONTINUE + ELSE + DO 120 J = 1, N + DO 110 I = 1, J + WORK( IRES+I+(J-1)*N ) = ABS( WORK( IRES+I+(J-1)*N ) ) + + $ FOUR*EPS*( ABS( C( I, J ) ) + ABS( X( I, J ) ) ) + + $ DBLE( 2*N + 3 )*EPS*WORK( ITMP+I+(J-1)*N ) + + $ DBLE( 2*N + 2 )*WORK( IDLC+1 ) + 110 CONTINUE + 120 CONTINUE + END IF +* +* Compute forward error bound, using matrix norm estimator +* + EST = ZERO + KASE = 0 + 130 CONTINUE + CALL DLACON( N*(N+1)/2, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IJ = 0 + IF( LOWER ) THEN + DO 150 J = 1, N + DO 140 I = J, N + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Scale by the residual matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ )* + $ WORK( IRES+I+(J-1)*N ) + ELSE +* +* Unpack the lower triangular part of symmetric +* matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + END IF + 140 CONTINUE + 150 CONTINUE + ELSE + DO 170 J = 1, N + DO 160 I = 1, J + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Scale by the residual matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ )* + $ WORK( IRES+I+(J-1)*N ) + ELSE +* +* Unpack the upper triangular part of symmetric +* matrix +* + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + END IF + 160 CONTINUE + 170 CONTINUE + END IF +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, + $ WORK, N, ZERO, WORK( ITMP+1 ), N ) + IF( KASE.EQ.2 ) THEN +* +* Solve op(A')*Y + Y*op(A) = scale*RHS +* + CALL LYPDTR( TRANA, N, T, LDT, WORK( ITMP+1 ), N, SCALE, + $ WORK( IWRK+1 ), INFO2 ) + ELSE +* +* Solve op(A)*Z + Z*op(A') = scale*RHS +* + CALL LYPDTR( TRANAT, N, T, LDT, WORK( ITMP+1 ), N, SCALE, + $ WORK( IWRK+1 ), INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, + $ U, LDU, ZERO, WORK( ITMP+1 ), N ) + IJ = 0 + IF( LOWER ) THEN + DO 190 J = 1, N + DO 180 I = J, N + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Pack the lower triangular part of symmetric +* matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + ELSE +* +* Scale by the residual matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N )* + $ WORK( IRES+I+(J-1)*N ) + END IF + 180 CONTINUE + 190 CONTINUE + ELSE + DO 210 J = 1, N + DO 200 I = 1, J + IJ = IJ + 1 + IF( KASE.EQ.2 ) THEN +* +* Pack the upper triangular part of symmetric +* matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + ELSE +* +* Scale by the residual matrix +* + WORK( IJ ) = WORK( ITMP+I+(J-1)*N )* + $ WORK( IRES+I+(J-1)*N ) + END IF + 200 CONTINUE + 210 CONTINUE + END IF + GO TO 130 + END IF +* +* Compute the estimate of the forward error +* + FERR = TWO*EST / DLANSY( 'Max', UPLO, N, X, LDX, WORK ) / SCALE + IF( FERR.GT.ONE ) FERR = ONE +* + RETURN +* +* End of RICDFR +* + END + SUBROUTINE RICDMF( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ WR, WI, RCOND, FERR, WORK, LWORK, IWORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDC, LDD, LDX, LWORK, N + DOUBLE PRECISION FERR, RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), D( LDD, * ), + $ X( LDX, * ), WI( * ), WORK( * ), WR( * ) +* .. +* +* Purpose +* ======= +* +* RICDMF solves the discrete-time matrix algebraic Riccati equation +* -1 +* transpose(op(A))*X*(In + D*X) *op(A) - X + C = 0 +* +* where op(A) = A or A**T and C, D are symmetric (C = C**T, D = D**T). +* The matrices A, C and D are N-by-N and the solution X is N-by-N. +* +* Error bound on the solution and a condition estimate are also +* provided. +* +* It is assumed that the matrices A, C and D are such that the +* corresponding matrix pencil has N eigenvalues with moduli +* less than one. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C, D and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangles of C and D are stored; +* = 'L': Lower triangles of C and D are stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N). +* +* D (input) DOUBLE PRECISION array, dimension (LDD,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of D +* contains the upper triangular part of the matrix D. +* If UPLO = 'L', the leading N-by-N lower triangular part of D +* contains the lower triangular part of the matrix D. +* +* LDD (input) INTEGER +* The leading dimension of the array D. LDD >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) +* On exit, if INFO = 0, WR(1:N) and WI(1:N) contain the real +* and imaginary parts, respectively, of the eigenvalues of +* -1 -1 +* Ac = (I + D*X) *A (if TRANA = 'N') or Ac = A*(I + X*D) +* (if TRANA = 'T' or 'C'). +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number of +* the discrete-time Riccati equation. +* +* FERR (output) DOUBLE PRECISION +* On exit, 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= 28*N*N + 2*N + +* max(1,2*N). +* For optimum performance LWORK >= 28*N*N + 2*N + ( 2*N+1 )*NB, +* where NB is the optimal blocksize. +* +* IWORK (workspace) INTEGER array, dimension max(2*N,N*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: the iteration for the spectral decomposition failed to +* converge after 50 iterations, but an approximate +* solution and error bounds have been computed +* = 2: the system of linear equations for the solution is +* singular to working precision +* -1 -1 +* = 3: the matrix Ac = (I + D*X) *A or Ac = A*(I + X*D) +* can not be reduced to Schur canonical form and condition +* number estimate and forward error estimate are not +* computed +* +* Further Details +* =============== +* +* The discrete-time matrix Riccati equation is solved by using the +* inverse free spectral decomposition method, proposed in [1]. +* +* The condition number of the equation is estimated using 1-norm +* estimator. +* +* The forward error bound is estimated using a practical error bound +* similar to the one proposed in [2]. +* +* References +* ========== +* +* [1] Z. Bai, J. Demmel and M. Gu. An inverse free parallel spectral +* divide and conquer algorithm for nonsymmetric eigenproblems. +* Numer. Math., vol. 76, pp. 279-308, 1997. +* [2] N.J. Higham. Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* [3] M.M. Konstantinov, P.Hr. Petkov, and N.D. Christov. Perturbation +* analysis of the discrete Riccati equation. Kybernetica (Prague), +* vol. 29,pp. 18-29, 1993. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 50 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA + CHARACTER EQUED + INTEGER I, IA, IAC, IAF, IB, IBR, IC, IFR, IJ, IJ1, + $ IJ2,INFO2, IQ, IR, IS, ISCL, ITAU, ITER, IU, + $ IV, IWFERR, IWRK, J, LWA, LWA0, LWAMAX, MINWRK, + $ N2, N4 + DOUBLE PRECISION CNORM, CNORM2, DNORM, DNORM2, EPS, RDNORM, + $ RNORM, TEMP, TOL +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEMM, DGEQP3, DGEQRF, DGERQF, DLACPY, + $ DLASET, DORMQR, DORMRQ, DGESVX, DLASCL, DSCAL, + $ RICDFR, RICDRC, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDD.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF +* +* Set tol +* + EPS = DLAMCH( 'Epsilon' ) + TOL = 10.0D+0*DBLE(N)*EPS +* +* Compute workspace +* + MINWRK = 28*N*N + 2*N + MAX( 1, 2*N ) + IF( LWORK.LT.MINWRK ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'RICDMF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Compute the norms of the matrices C and D +* + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + DNORM = DLANSY( '1', UPLO, N, D, LDD, WORK ) +* + N2 = 2*N + N4 = 4*N +* +* Construct B0 and -A0 +* + DO 20 J = 1, N + DO 10 I = 1, N + IJ = ( N + J - 1 )*N2 + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) THEN + WORK( IJ ) = D( I, J ) + ELSE + WORK( IJ ) = D( J, I ) + END IF + ELSE + IF( I.GE.J ) THEN + WORK( IJ ) = D( I, J ) + ELSE + WORK( IJ ) = D( J, I ) + END IF + END IF + IJ = ( N + J - 1 )*N2 + N + I + IF( NOTRNA ) THEN + WORK( IJ ) = A( J, I ) + ELSE + WORK( IJ ) = A( I, J ) + END IF + IJ = N2*N2 + ( J - 1 )*N2 + I + IF( NOTRNA ) THEN + WORK( IJ ) = -A( I, J ) + ELSE + WORK( IJ ) = -A( J, I ) + END IF + IJ = N2*N2 + ( J - 1)*N2 + N + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) THEN + WORK( IJ ) = C( I, J ) + ELSE + WORK( IJ ) = C( J, I ) + END IF + ELSE + IF( I.GE.J ) THEN + WORK( IJ ) = C( I, J ) + ELSE + WORK( IJ ) = C( J, I ) + END IF + END IF + 10 CONTINUE + 20 CONTINUE + CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK( N+1 ), N2 ) + CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK( N2*N2+N2*N+1 ), N2 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, N2 ) + CALL DLASET( 'Full', N, N, ZERO, -ONE, WORK( N2*N2+N2*N+N+1 ), + $ N2 ) +* +* Scale the matrices B0 and -A0 +* + CNORM2 = SQRT( CNORM ) + DNORM2 = SQRT( DNORM ) + ISCL = 0 + IF( CNORM2.GT.DNORM2 .AND. DNORM2.GT.ZERO ) THEN + CALL DLASCL( 'G', 0, 0, CNORM2, DNORM2, N, N, + $ WORK( N2*N2+N+1 ), N2, INFO2 ) + CALL DLASCL( 'G', 0, 0, DNORM2, CNORM2, N, N, + $ WORK( N2*N+1 ), N2, INFO2 ) + ISCL = 1 + END IF +* +* Workspace usage +* + LWA0 = 28*N*N + 2*N + LWAMAX = 0 + IA = N2*N2 + IR = IA + N2*N2 + IS = IR + N4*N2 + IQ = IS + N2*N2 + ITAU = IQ + N4*N2 + IWRK = ITAU + N2 +* +* Copy B0 and -A0 +* + CALL DLACPY( 'F', N2, N2, WORK, N2, WORK( IR+1 ), N4 ) + CALL DLACPY( 'F', N2, N2, WORK( IA+1 ), N2, WORK( IR+N2+1 ), N4 ) +* +* Main iteration loop +* + DO 60 ITER = 1, MAXIT +* +* [ Bj] +* QR decomposition of [ ] +* [-Aj] +* + CALL DGEQRF( N4, N2, WORK( IR+1 ), N4, WORK( ITAU+1 ), + $ WORK( IWRK+1 ), LWORK-IWRK, INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Make the diagonal elements of Rj positive +* + DO 30 I = 1, N2 + IF( WORK( IR+(I-1)*N4+I ).LT.ZERO ) + $ CALL DSCAL( N2-I+1, -ONE, WORK( IR+(I-1)*N4+I ), N4 ) + 30 CONTINUE + IF( ITER.GT.1 ) THEN +* +* Compute Rj+1 - Rj +* + DO 50 J = 1, N2 + DO 40 I = 1, J + IJ1 = IR + ( J - 1 )*N4 + I + IJ2 = IS + ( J - 1 )*N2 + I + WORK( IJ2 ) = WORK( IJ1 ) - WORK( IJ2 ) + 40 CONTINUE + 50 CONTINUE + RDNORM = DLANGE( '1', N2, N2, WORK( IS+1 ), N2, + $ WORK( IWRK+1 )) + END IF +* +* Save Rj for future use +* + CALL DLACPY( 'U', N2, N2, WORK( IR+1 ), N4, WORK( IS+1 ), N2 ) + IF( ITER.EQ.1 ) + $ CALL DLASET( 'L', N2-1, N2-1, ZERO, ZERO, WORK( IS+2 ), N2 ) +* +* Generate the matrices Q12 and Q22 +* + CALL DLASET( 'F', N2, N2, ZERO, ZERO, WORK( IQ+1 ), N4 ) + CALL DLASET( 'F', N2, N2, ZERO, ONE, WORK( IQ+N2+1 ), N4 ) + CALL DORMQR( 'L', 'N', N4, N2, N2, WORK( IR+1 ), N4, + $ WORK( ITAU+1 ), WORK( IQ+1 ), N4, WORK( IWRK+1 ), + $ LWORK-IWRK, INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Compute Bj and -Aj +* + CALL DGEMM( 'T', 'N', N2, N2, N2, ONE, WORK( IQ+N2+1 ), + $ N4, WORK, N2, ZERO, WORK( IR+1 ), N4 ) + CALL DGEMM( 'T', 'N', N2, N2, N2, ONE, WORK( IQ+1 ), N4, + $ WORK( IA+1 ), N2, ZERO, WORK( IR+N2+1 ), N4 ) + CALL DLACPY( 'F', N2, N2, WORK( IR+1 ), N4, WORK, N2 ) + CALL DLACPY( 'F', N2, N2, WORK( IR+N2+1 ), N4, WORK( IA+1 ), + $ N2 ) +* +* Test for convergence +* + IF( ITER.GT.1 .AND. RDNORM.LE.TOL*RNORM ) GO TO 70 + RNORM = DLANGE( '1', N2, N2, WORK( IS+1 ), N2, + $ WORK( IWRK+1 )) + 60 CONTINUE + INFO = 1 + 70 LWA0 =10*N*N + 2*N + IQ = IA + N2*N2 + ITAU = IQ + N2*N + IWRK = ITAU + N2 +* +* Compute Ap + Bp +* + CALL DSCAL( N2*N2, -ONE, WORK( IA+1 ), 1 ) + CALL DAXPY( N2*N2, ONE, WORK, 1, WORK( IA+1 ), 1 ) +* +* QR decomposition with column pivoting of Bp +* + DO 80 J = 1, N2 + IWORK( J ) = 0 + 80 CONTINUE + CALL DGEQP3( N2, N2, WORK, N2, IWORK, WORK( ITAU+1 ), + $ WORK( IWRK+1 ), LWORK-IWRK, INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* T +* Compute Q1 (Ap + Bp) +* + CALL DORMQR( 'L', 'T', N2, N2, N2, WORK, N2, WORK( ITAU+1 ), + $ WORK( IA+1 ), N2, WORK( IWRK+1 ), LWORK-IWRK, + $ INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* T +* RQ decomposition of Q1 (Ap + Bp) +* + CALL DGERQF( N2, N2, WORK( IA+1 ), N2, WORK( ITAU+1 ), + $ WORK( IWRK+1 ), LWORK-IWRK, INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Generate Q11 and Q21 +* + CALL DLASET( 'F', N, N, ZERO, ONE, WORK( IQ+1 ), N2 ) + CALL DLASET( 'F', N, N, ZERO, ZERO, WORK( IQ+N+1 ), N2 ) + CALL DORMRQ( 'L', 'T', N2, N, N2, WORK( IA+1 ), N2, + $ WORK( ITAU+1 ), WORK( IQ+1 ), N2, WORK( IWRK+1 ), + $ LWORK-IWRK, INFO2 ) + LWA = LWA0 + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Store the matrices Q11 and Q21 +* + DO 100 J = 1, N + DO 90 I = 1, N + IJ = ( J - 1 )*N + I + IV = IQ + ( I - 1 )*N2 + J + WORK( IJ ) = WORK( IV ) + IJ = ( J - 1 )*N + 2*N*N + I + IV = IQ + ( I - 1 )*N2 + N + J + WORK( IJ ) = WORK( IV ) + 90 CONTINUE + 100 CONTINUE +* +* Workspace usage +* + IAF = N*N + IB = IAF + N*N + IR = IB + N*N + IC = IR + N + IFR = IC + N + IBR = IFR + N + IWRK = IBR + N +* +* Compute the solution matrix X +* + CALL DGESVX( 'E', 'N', N, N, WORK, N, WORK( IAF+1 ), N, + $ IWORK, EQUED, WORK( IR+1 ), WORK( IC+1 ), + $ WORK( IB+1 ), N, X, LDX, RCOND, WORK( IFR+1 ), + $ WORK( IBR+1 ), WORK( IWRK+1 ), IWORK( N+1 ), + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +* +* Symmetrize the solution +* + IF( N.GT.1 ) THEN + DO 120 I = 1, N - 1 + DO 110 J = I + 1, N + TEMP = ( X( I, J ) + X( J, I ) ) / TWO + X( I, J ) = TEMP + X( J, I ) = TEMP + 110 CONTINUE + 120 CONTINUE + END IF +* +* Undo scaling for the solution matrix +* + IF( ISCL.EQ.1 ) + $ CALL DLASCL( 'G', 0, 0, DNORM2, CNORM2, N, N, X, LDX, INFO2 ) +* +* Workspace usage +* + LWA = 3*N*N + N + IU = N*N + IWFERR = IU + N*N + IAC = IWFERR + N + IWRK = IAC + N*N +* +* Estimate the reciprocal condition number +* + CALL RICDRC( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ RCOND, WORK( IAC+1 ), N, WORK, N, WORK( IU+1 ), N, + $ WR, WI, WORK( IWFERR+1 ), WORK( IWRK+1 ), LWORK-IWRK, + $ IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF + LWA = LWA + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Return if the equation is singular +* + IF( RCOND.EQ.ZERO ) THEN + FERR = ONE + WORK( 1 ) = DBLE( LWAMAX ) + RETURN + END IF +* +* Estimate the bound on the forward error +* + CALL RICDFR( TRANA, N, A, LDA, UPLO, C, LDC, X, LDX, + $ WORK( IAC+1 ), N, WORK, N, WORK( IU+1 ), N, + $ WORK( IWFERR+1 ), FERR, WORK( IWRK+1 ), + $ LWORK-IWRK, IWORK, INFO2 ) + LWA = 9*N*N + 3*N + LWAMAX = MAX( LWA, LWAMAX ) + WORK( 1 ) = DBLE( LWAMAX ) + RETURN +* +* End of RICDMF +* + END + SUBROUTINE RICDRC( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ RCOND, AC, LDAC, T, LDT, U, LDU, WR, WI, WFERR, + $ WORK, LWORK, IWORK, INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDAC, LDC, LDD, LDT, LDU, LDX, + $ LWORK, N + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), C( LDC, * ), + $ D( LDD, * ), T( LDT, * ), U( LDU, * ), + $ WFERR( * ), WI( * ), WORK( * ), WR( * ), + $ X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* RICDRC estimates the reciprocal of the condition number of the +* discrete-time matrix algebraic Riccati equation +* +* -1 +* transpose(op(A))*X*(In + D*X) *op(A) - X + C = 0 +* +* where op(A) = A or A**T and C, D are symmetric (C = C**T, D = D**T). +* The matrices A, C, D and X are N-by-N. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C, D and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangles of C and D are stored; +* = 'L': Lower triangles of C and D are stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N). +* +* D (input) DOUBLE PRECISION array, dimension (LDD,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of D +* contains the upper triangular part of the matrix D. +* If UPLO = 'L', the leading N-by-N lower triangular part of D +* contains the lower triangular part of the matrix D. +* +* LDD (input) INTEGER +* The leading dimension of the array D. LDD >= max(1,N). +* +* X (input) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDC >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number +* of the discrete-time Riccati equation. +* If X = 0, RCOND is set to zero. +* +* AC (output) DOUBLE PRECISION array, dimension (LDAC,N) +* On exit, if INFO = 0, AC contains the matrix +* -1 -1 +* Ac = (I + D*X) *A (if TRANA = 'N') or Ac = A*(I + X*D) +* (if TRANA = 'T' or 'C'). +* +* LDAC (input) INTEGER +* The leading dimension of the array AC. LDAC >= max(1,N). +* +* T (output) DOUBLE PRECISION array, dimension (LDT,N) +* The upper quasi-triangular matrix in Schur canonical form +* from the Schur factorization of the matrix Ac. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max(1,N) +* +* U (output) DOUBLE PRECISION array, dimension (LDU,N) +* The orthogonal N-by-N matrix from the real Schur +* factorization of the matrix Ac. +* +* LDU (input) INTEGER +* The leading dimension of the array U. LDU >= max(1,N) +* +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) +* On exit, WR(1:N) and WI(1:N) contain the real and imaginary +* parts, respectively, of the eigenvalues of the matrix Ac. +* +* WFERR (output) DOUBLE PRECISION array, dimension (N) +* On exit, if INFO = 0, WFERR contains the estimated forward +* error bound for each column of the matrix Ac. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK INTEGER +* The dimension of the array WORK. LWORK >= 5*N*N + 3*N + +* max(1,4*N). +* For good performance, LWORK must generally be larger. +* +* IWORK (workspace) INTEGER array, dimension max(2*N,N*N) +* +* INFO INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: the matrix I + D*X is singular to working precision +* and condition number estimate is not computed +* = 2: the matrix Ac can not be reduced to Schur canonical +* form and condition number estimate is not computed +* +* Further details +* =============== +* +* The condition number of the discrete-time Riccati equation is +* estimated as +* +* cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(C) + +* norm(Pi)*norm(D) ) / norm(X) +* +* where Omega, Theta and Pi are linear operators defined by +* +* Omega(Z) = transpose(op(Ac))*Z*op(Ac) - Z, +* Theta(Z) = inv(Omega(transpose(op(Z))*X*op(Ac) + +* transpose(op(Ac))*X*op(Z))), +* Pi(Z) = inv(Omega(transpose(op(Ac))*X*Z*X*op(Ac))) +* -1 -1 +* and Ac = (I + D*X) *A (if TRANA = 'N') or Ac = A*(I + X*D) +* (if TRANA = 'T' or 'C'). +* +* The program estimates the quantities +* +* sepd(op(Ac),transpose(op(Ac)) = 1 / norm(inv(Omega)), +* +* norm(Theta) and norm(Pi) using 1-norm condition estimator. +* +* References +* ========== +* +* [1] N.J. Higham. Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* [2] M.M. Konstantinov, P.Hr. Petkov, and N.D. Christov. Perturbation +* analysis of the discrete Riccati equation. Kybernetica (Prague), +* vol. 29,pp. 18-29, 1993. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA, VOIDDUMMY + CHARACTER EQUED, TRANAT + INTEGER I, IAF, IBR, IC, IDLC, IJ, INFO2, IR, ITMP, + $ IWRK, IXMA, J, KASE, LWA, MINWRK, SDIM + DOUBLE PRECISION ANORM, CNORM, DNORM, EST, PINORM, SCALE, SEPD, + $ THNORM, WRCON, XNORM +* .. +* .. Local Arrays .. + LOGICAL BWORK( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANGE, DLANSY + EXTERNAL DLANGE, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DGESVX, DLACON, DLACPY, DLASET, + $ DSYMM, DSYR2K, LYPDTR, XERBLA, VOIDDUMMY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDD.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDAC.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -18 + END IF +* +* Compute workspace +* + MINWRK = 5*N*N +3*N + MAX( 1, 4*N ) + IF( LWORK.LT.MINWRK ) THEN + INFO = -23 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'RICDRC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + XNORM = DLANSY( '1', UPLO, N, X, LDX, WORK ) + IF( XNORM.EQ.ZERO ) THEN + RCOND = ZERO + RETURN + END IF +* +* Compute the norms of the matrices A, C and D +* + ANORM = DLANGE( '1', N, N, A, LDA, WORK ) + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + DNORM = DLANSY( '1', UPLO, N, D, LDD, WORK ) +* +* Workspace usage +* + LWA = 5*N*N + 3*N + IDLC = N*N + ITMP = IDLC + N*N + IXMA = ITMP + N*N + IAF = IXMA + N*N + IR = IAF + N*N + IC = IR + N + IBR = IC + N + IWRK = IBR + N +* + CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, N ) + CALL DSYMM( 'L', UPLO, N, N, ONE, D, LDD, X, LDX, ONE, + $ WORK, N ) + IF( NOTRNA ) THEN +* -1 +* Compute Ac = (I + D*X) *A +* + CALL DLACPY( 'F', N, N, A, LDA, T, LDT ) + CALL DGESVX( 'E', 'N', N, N, WORK, N, WORK( IAF+1 ), N, IWORK, + $ EQUED, WORK( IR+1 ), WORK( IC+1 ), T, LDT, AC, + $ LDAC, WRCON, WFERR, WORK( IBR+1 ), WORK( IWRK+1 ), + $ IWORK( N+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + ELSE +* -1 +* Compute Ac = A*(I + X*D) +* + DO 20 J = 1, N + DO 10 I = 1, N + T( I, J ) = A( J, I ) + 10 CONTINUE + 20 CONTINUE + CALL DGESVX( 'E', 'N', N, N, WORK, N, WORK( IAF+1 ), N, IWORK, + $ EQUED, WORK( IR+1 ), WORK( IC+1 ), T, LDT, + $ WORK( ITMP+1 ), N, WRCON, WFERR, WORK( IBR+1 ), + $ WORK( IWRK+1 ), IWORK( N+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + DO 40 J = 1, N + DO 30 I = 1, N + AC( I, J ) = WORK( ITMP+J+(I-1)*N ) + 30 CONTINUE + 40 CONTINUE + END IF +* +* Compute the Schur factorization of Ac +* + CALL DLACPY( 'F', N, N, AC, LDAC, T, LDT ) + CALL DGEES( 'V', 'N', VOIDDUMMY, N, T, LDT, SDIM, + $ WR, WI, U, LDU, + $ WORK( IWRK+1 ), LWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF + LWA = LWA + INT( WORK( IWRK+1 ) ) +* +* Compute X*op(Ac) +* + CALL DGEMM( 'N', TRANA, N, N, N, ONE, X, LDX, AC, LDAC, ZERO, + $ WORK( IXMA+1 ), N ) +* +* Estimate sepd(op(Ac),transpose(op(Ac))) +* + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +* + EST = ZERO + KASE = 0 + 50 CONTINUE + CALL DLACON( N*(N+1)/2, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +* +* Unpack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 70 J = 1, N + DO 60 I = J, N + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 60 CONTINUE + 70 CONTINUE + ELSE + DO 90 J = 1, N + DO 80 I = 1, J + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 80 CONTINUE + 90 CONTINUE + END IF +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, U, LDU, + $ ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK, N, ZERO, + $ WORK( ITMP+1 ), N ) + IF( KASE.EQ.1 ) THEN +* +* Solve op(Ac')*Y*op(Ac) - Y = scale*RHS +* + CALL LYPDTR( TRANA, N, T, LDT, WORK( ITMP+1 ), N, SCALE, + $ WORK( IWRK+1 ), INFO2 ) + ELSE +* +* Solve op(Ac)*Z*op(Ac') - Z = scale*RHS +* + CALL LYPDTR( TRANAT, N, T, LDT, WORK( ITMP+1 ), N, SCALE, + $ WORK( IWRK+1 ), INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, U, LDU, + $ ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) +* +* Pack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 110 J = 1, N + DO 100 I = J, N + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 100 CONTINUE + 110 CONTINUE + ELSE + DO 130 J = 1, N + DO 120 I = 1, J + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 120 CONTINUE + 130 CONTINUE + END IF + GO TO 50 + END IF +* + SEPD = SCALE / TWO / EST +* +* Return if the equation is singular +* + IF( SEPD.EQ.ZERO ) THEN + RCOND = ZERO + RETURN + END IF +* +* Estimate norm(Theta) +* + EST = ZERO + KASE = 0 + 140 CONTINUE + CALL DLACON( N*N, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +* +* Compute RHS = op(W')*X*op(A) + op(A')*X*op(W) +* + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, WORK, N, WORK( IXMA+1 ), + $ N, ZERO, WORK( ITMP+1 ), N ) + CALL DLACPY( UPLO, N, N, WORK( ITMP+1 ), N, WORK, N ) +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, WORK( ITMP+1 ), + $ N, ZERO, WORK, N ) + IF( KASE.EQ.1 ) THEN +* +* Solve op(Ac')*Y*op(Ac) - Y = scale*RHS +* + CALL LYPDTR( TRANA, N, T, LDT, WORK, N, SCALE, + $ WORK( IWRK+1 ), INFO2 ) + ELSE +* +* Solve op(Ac)*Z*op(Ac') - Z = scale*RHS +* + CALL LYPDTR( TRANAT, N, T, LDT, WORK, N, SCALE, + $ WORK( IWRK+1 ), INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK, N, U, LDU, ZERO, + $ WORK( ITMP+1 ), N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK( ITMP+1 ), N, U, + $ LDU, ZERO, WORK, N ) + GO TO 140 + END IF +* + THNORM = EST / SCALE +* +* Estimate norm(Pi) +* + EST = ZERO + KASE = 0 + 150 CONTINUE + CALL DLACON( N*(N+1)/2, WORK( IDLC+1 ), WORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +* +* Unpack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 170 J = 1, N + DO 160 I = J, N + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 160 CONTINUE + 170 CONTINUE + ELSE + DO 190 J = 1, N + DO 180 I = 1, J + IJ = IJ + 1 + WORK( ITMP+I+(J-1)*N ) = WORK( IJ ) + 180 CONTINUE + 190 CONTINUE + END IF +* +* Compute RHS = op(Ac')*X*W*X*op(Ac) +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ WORK( IXMA+1 ), N, ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, WORK( IXMA+1 ), N, WORK, + $ N, ZERO, WORK( ITMP+1 ), N ) +* +* Transform the right-hand side: RHS := U'*RHS*U +* + CALL DSYMM( 'L', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, + $ WORK, N, ZERO, WORK( ITMP+1 ), N ) + IF( KASE.EQ.1 ) THEN +* +* Solve op(Ac')*Y*op(Ac) - Y = scale*RHS +* + CALL LYPDTR( TRANA, N, T, LDT, WORK( ITMP+1 ), N, SCALE, + $ WORK( IWRK+1 ), INFO2 ) + ELSE +* +* Solve op(Ac)*Z*op(Ac') - Z = scale*RHS +* + CALL LYPDTR( TRANAT, N, T, LDT, WORK( ITMP+1 ), N, SCALE, + $ WORK( IWRK+1 ), INFO2 ) + END IF +* +* Transform back to obtain the solution: X := U*X*U' . +* + CALL DSYMM( 'R', UPLO, N, N, ONE, WORK( ITMP+1 ), N, + $ U, LDU, ZERO, WORK, N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, WORK, N, + $ U, LDU, ZERO, WORK( ITMP+1 ), N ) +* +* Pack the triangular part of symmetric matrix +* + IJ = 0 + IF( LOWER ) THEN + DO 210 J = 1, N + DO 200 I = J, N + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 200 CONTINUE + 210 CONTINUE + ELSE + DO 230 J = 1, N + DO 220 I = 1, J + IJ = IJ + 1 + WORK( IJ ) = WORK( ITMP+I+(J-1)*N ) + 220 CONTINUE + 230 CONTINUE + END IF + GO TO 150 + END IF +* + PINORM = TWO*EST / SCALE +* +* Estimate the reciprocal condition number +* + RCOND = SEPD*XNORM / ( CNORM + SEPD*( THNORM*ANORM + + $ PINORM*DNORM ) ) + IF( RCOND.GT.ONE ) RCOND = ONE +* + WORK( 1 ) = DBLE( LWA ) + RETURN +* +* End of RICDRC +* + END + SUBROUTINE RICDSL( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ WR, WI, RCOND, FERR, WORK, LWORK, IWORK, BWORK, + $ INFO ) +* +* -- RICCPACK routine (version 1.0) -- +* May 10, 2000 +* +* .. Scalar Arguments .. + CHARACTER TRANA, UPLO + INTEGER INFO, LDA, LDC, LDD, LDX, LWORK, N + DOUBLE PRECISION FERR, RCOND +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), D( LDD, * ), + $ X( LDX, * ), WI( * ), WORK( * ), WR( * ) +* .. +* +* Purpose +* ======= +* +* RICDSL solves the discrete-time matrix algebraic Riccati equation +* -1 +* transpose(op(A))*X*(In + D*X) *op(A) - X + C = 0 +* +* where op(A) = A or A**T and C, D are symmetric (C = C**T, D = D**T). +* The matrices A, C and D are N-by-N and the solution X is N-by-N. +* +* Error bound on the solution and a condition estimate are also +* provided. +* +* It is assumed that the matrices A, C and D are such that the +* corresponding matrix pencil has N eigenvalues with moduli +* less than one. +* +* Arguments +* ========= +* +* TRANA (input) 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) +* +* N (input) INTEGER +* The order of the matrix A, and the order of the +* matrices C, D and X. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangles of C and D are stored; +* = 'L': Lower triangles of C and D are stored. +* +* C (input) DOUBLE PRECISION array, dimension (LDC,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of C +* contains the upper triangular part of the matrix C. +* If UPLO = 'L', the leading N-by-N lower triangular part of C +* contains the lower triangular part of the matrix C. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,N). +* +* D (input) DOUBLE PRECISION array, dimension (LDD,N) +* If UPLO = 'U', the leading N-by-N upper triangular part of D +* contains the upper triangular part of the matrix D. +* If UPLO = 'L', the leading N-by-N lower triangular part of D +* contains the lower triangular part of the matrix D. +* +* LDD (input) INTEGER +* The leading dimension of the array D. LDD >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,N) +* The N-by-N solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) +* On exit, if INFO = 0, WR(1:N) and WI(1:N) contain the real +* and imaginary parts, respectively, of the eigenvalues of +* -1 -1 +* Ac = (I + D*X) *A (if TRANA = 'N') or Ac = A*(I + X*D) +* (if TRANA = 'T' or 'C'). +* +* RCOND (output) DOUBLE PRECISION +* On exit, an estimate of the reciprocal condition number of +* the discrete-time Riccati equation. +* +* FERR (output) DOUBLE PRECISION +* On exit, 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. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= 12*N*N + 22*N + +* max(16,4*N). +* For good performance, LWORK must generally be larger. +* +* IWORK (workspace) INTEGER array, dimension max(2*N,N*N) +* +* BWORK (workspace) LOGICAL array, dimension (2*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1: the QZ algorithm failed to compute the eigenvalues of +* the matrix pencil +* = 2: after reordering, roundoff changed values of some +* complex eigenvalues so that leading eigenvalues in +* the generalized Schur form have no longer moduli +* less than one +* = 3: reordering of the generalized Shur form failed +* = 4: the matrix pencil has less than N generalized +* eigenvalues with moduli less than one +* = 5: the system of linear equations for the solution is +* singular to working precision +* -1 -1 +* = 6: the matrix Ac = (I + D*X) *A or Ac = A*(I + X*D) +* can not be reduced to Schur canonical form and condition +* number estimate and forward error estimate are not +* computed +* +* Further Details +* =============== +* +* The discrete-time matrix Riccati equation is solved by the +* generalized Schur method [1]. +* +* The condition number of the equation is estimated using 1-norm +* estimator. +* +* The forward error bound is estimated using a practical error bound +* similar to the one proposed in [2]. +* +* References +* ========== +* +* [1] W.F Arnold, III and A.J. Laub. Generalized eigenproblem +* algorithms and software for algebraic Riccati equations, +* Proc. IEEE, vol. 72, pp. 1746-1754, 1984. +* [2] N.J. Higham. Perturbation theory and backward error for AX - XB = +* C, BIT, vol. 33, pp. 124-136, 1993. +* [3] M.M. Konstantinov, P.Hr. Petkov, and N.D. Christov. Perturbation +* analysis of the discrete Riccati equation. Kybernetica (Prague), +* vol. 29,pp. 18-29, 1993. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NOTRNA + CHARACTER EQUED + INTEGER I, IAC, IAF, IALFAI, IALFAR, IB, IBETA, IBR, + $ IC, IFR, IJ, INFO2, IR, ISCL, IU, IV, IVS, + $ IWFERR,IWRK, J, LWA, LWAMAX, MINWRK, N2, SDIM + DOUBLE PRECISION CNORM, CNORM2, DNORM, DNORM2, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME, SELMLO + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY, LSAME, SELMLO +* .. +* .. External Subroutines .. + EXTERNAL DGESVX, DGGES, DLASCL, DLASET, RICDFR, RICDRC, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode and Test input parameters +* + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +* + 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( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDD.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF +* +* Compute workspace +* + MINWRK = 12*N*N + 22*N + MAX( 16, 4*N ) + IF( LWORK.LT.MINWRK ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'RICDSL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Compute the norms of the matrices C and D +* + CNORM = DLANSY( '1', UPLO, N, C, LDC, WORK ) + DNORM = DLANSY( '1', UPLO, N, D, LDD, WORK ) +* + N2 = 2*N +* +* Construct the matrix pencil +* + DO 20 J = 1, N + DO 10 I = 1, N + IJ = ( J - 1 )*N2 + I + IF( NOTRNA ) THEN + WORK( IJ ) = A( I, J ) + ELSE + WORK( IJ ) = A( J, I ) + END IF + IJ = ( J - 1 )*N2 + N + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) THEN + WORK( IJ ) = -C( I, J ) + ELSE + WORK( IJ ) = -C( J, I ) + END IF + ELSE + IF( I.GE.J ) THEN + WORK( IJ ) = -C( I, J ) + ELSE + WORK( IJ ) = -C( J, I ) + END IF + END IF + IJ = N2*N2 + ( N + J - 1 )*N2 + I + IF( .NOT.LOWER ) THEN + IF( I.LE.J ) THEN + WORK( IJ ) = D( I, J ) + ELSE + WORK( IJ ) = D( J, I ) + END IF + ELSE + IF( I.GE.J ) THEN + WORK( IJ ) = D( I, J ) + ELSE + WORK( IJ ) = D( J, I ) + END IF + END IF + IJ = N2*N2 + ( N + J - 1)*N2 + N + I + IF( NOTRNA ) THEN + WORK( IJ ) = A( J, I ) + ELSE + WORK( IJ ) = A( I, J ) + END IF + 10 CONTINUE + 20 CONTINUE + CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK( N2*N+1 ), N2 ) + CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK( N2*N2+N+1 ), N2 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, WORK( N2*N+N+1 ), N2 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, WORK( N2*N2+1 ), N2 ) +* +* Scale the matrix pencil +* + CNORM2 = SQRT( CNORM ) + DNORM2 = SQRT( DNORM ) + ISCL = 0 + IF( CNORM2.GT.DNORM2 .AND. DNORM2.GT.ZERO ) THEN + CALL DLASCL( 'G', 0, 0, CNORM2, DNORM2, N, N, WORK( N+1 ), N2, + $ INFO2 ) + CALL DLASCL( 'G', 0, 0, DNORM2, CNORM2, N, N, + $ WORK( N2*N2+N2*N+1 ), N2, INFO2 ) + ISCL = 1 + END IF +* +* Workspace usage +* + LWA = 12*N*N + 6*N + IALFAR = 2*N2*N2 + IALFAI = IALFAR + N2 + IBETA = IALFAI + N2 + IVS = IBETA + N2 + IWRK = IVS + N2*N2 +* +* Compute the generalized Schur factorization of the matrix pencil +* + CALL DGGES( 'N', 'V', 'S', SELMLO, N2, WORK, N2, WORK( N2*N2+1 ), + $ N2, SDIM, WORK( IALFAR+1 ), WORK( IALFAI+1 ), + $ WORK( IBETA+1 ), WORK( IVS+1 ), N2, WORK( IVS+1 ), + $ N2, WORK( IWRK+1 ), LWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.GT.0 .AND. INFO2.LE.N2+1 ) THEN + INFO = 1 + RETURN + ELSE IF( INFO2.EQ.N2+2 ) THEN + INFO = 2 + RETURN + ELSE IF( INFO2.EQ.N2+3 ) THEN + INFO = 3 + RETURN + ELSE IF( SDIM.NE.N ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = LWA + INT( WORK( IWRK+1 ) ) +* +* Store the matrices V11 and V21 +* + DO 40 J = 1, N + DO 30 I = 1, N + IJ = ( J - 1 )*N + I + IV = ( I - 1 )*N2 + IVS + J + WORK( IJ ) = WORK( IV ) + IJ = ( J - 1 )*N + 2*N*N + I + IV = ( I - 1 )*N2 + IVS + N + J + WORK( IJ ) = WORK( IV ) + 30 CONTINUE + 40 CONTINUE +* +* Workspace usage +* + IAF = N*N + IB = IAF + N*N + IR = IB + N*N + IC = IR + N + IFR = IC + N + IBR = IFR + N + IWRK = IBR + N +* +* Compute the solution matrix X +* + CALL DGESVX( 'E', 'N', N, N, WORK, N, WORK( IAF+1 ), N, + $ IWORK, EQUED, WORK( IR+1 ), WORK( IC+1 ), + $ WORK( IB+1 ), N, X, LDX, RCOND, WORK( IFR+1 ), + $ WORK( IBR+1 ), WORK( IWRK+1 ), IWORK( N+1 ), + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF +* +* Symmetrize the solution +* + IF( N.GT.1 ) THEN + DO 60 I = 1, N - 1 + DO 50 J = I + 1, N + TEMP = ( X( I, J ) + X( J, I ) ) / TWO + X( I, J ) = TEMP + X( J, I ) = TEMP + 50 CONTINUE + 60 CONTINUE + END IF +* +* Undo scaling for the solution matrix +* + IF( ISCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, DNORM2, CNORM2, N, N, X, LDX, INFO2 ) + END IF +* +* Workspace usage +* + LWA = 3*N*N + N + IU = N*N + IWFERR = IU + N*N + IAC = IWFERR + N + IWRK = IAC + N*N +* +* Estimate the reciprocal condition number +* + CALL RICDRC( TRANA, N, A, LDA, UPLO, C, LDC, D, LDD, X, LDX, + $ RCOND, WORK( IAC+1 ), N, WORK, N, WORK( IU+1 ), N, + $ WR, WI, WORK( IWFERR+1 ), WORK( IWRK+1 ), LWORK-IWRK, + $ IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LWA = LWA + INT( WORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +* +* Return if the equation is singular +* + IF( RCOND.EQ.ZERO ) THEN + FERR = ONE + RETURN + END IF +* +* Estimate the bound on the forward error +* + CALL RICDFR( TRANA, N, A, LDA, UPLO, C, LDC, X, LDX, + $ WORK( IAC+1 ), N, WORK, N, WORK( IU+1 ), N, + $ WORK( IWFERR+1 ), FERR, WORK( IWRK+1 ), + $ LWORK-IWRK, IWORK, INFO2 ) + LWA = 9*N*N + 3*N + LWAMAX = MAX( LWA, LWAMAX ) + WORK( 1 ) = DBLE( LWAMAX ) + RETURN +* +* End of RICDSL +* + END + + LOGICAL FUNCTION SELMLO( ALPHAR, ALPHAI, BETA ) +* +* -- LISPACK auxiliary routine (version 3.0) -- +* Tech. University of Sofia +* September 22, 1999 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHAR, ALPHAI, BETA +* .. +* +* Purpose +* ======= +* +* SELMLO is used to select eigenvalues with modules less than one +* to sort to the top left of the generalized Schur form of the +* matrix pencil in solving discrete-time matrix algebraic Riccati +* equations +* +* .. External Functions .. + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2 +* +* .. Intrinsic Functions .. + INTRINSIC ABS +* +* .. Executable Statements .. +* + SELMLO = DLAPY2( ALPHAR, ALPHAI ).LT.ABS( BETA ) +* +* End of SELMLO +* + END diff --git a/modules/cacsd/src/slicot/riccpack.lo b/modules/cacsd/src/slicot/riccpack.lo new file mode 100755 index 000000000..a39b66269 --- /dev/null +++ b/modules/cacsd/src/slicot/riccpack.lo @@ -0,0 +1,12 @@ +# src/slicot/riccpack.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/riccpack.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02mr.f b/modules/cacsd/src/slicot/sb02mr.f new file mode 100755 index 000000000..704fcd6a2 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02mr.f @@ -0,0 +1,59 @@ + LOGICAL FUNCTION SB02MR( REIG, IEIG ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To select the unstable eigenvalues for solving the continuous-time +C algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C REIG (input) DOUBLE PRECISION +C The real part of the current eigenvalue considered. +C +C IEIG (input) DOUBLE PRECISION +C The imaginary part of the current eigenvalue considered. +C +C METHOD +C +C The function value SB02MR is set to .TRUE. for an unstable +C eigenvalue and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION IEIG, REIG +C .. Executable Statements .. +C + SB02MR = REIG.GE.ZERO +C + RETURN +C *** Last line of SB02MR *** + END diff --git a/modules/cacsd/src/slicot/sb02mr.lo b/modules/cacsd/src/slicot/sb02mr.lo new file mode 100755 index 000000000..bc007548b --- /dev/null +++ b/modules/cacsd/src/slicot/sb02mr.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02mr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02mr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02ms.f b/modules/cacsd/src/slicot/sb02ms.f new file mode 100755 index 000000000..ed4f8c5ab --- /dev/null +++ b/modules/cacsd/src/slicot/sb02ms.f @@ -0,0 +1,63 @@ + LOGICAL FUNCTION SB02MS( REIG, IEIG ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To select the unstable eigenvalues for solving the discrete-time +C algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C REIG (input) DOUBLE PRECISION +C The real part of the current eigenvalue considered. +C +C IEIG (input) DOUBLE PRECISION +C The imaginary part of the current eigenvalue considered. +C +C METHOD +C +C The function value SB02MS is set to .TRUE. for an unstable +C eigenvalue (i.e., with modulus greater than or equal to one) and +C to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, discrete-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION IEIG, REIG +C .. External Functions .. + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2 +C .. Executable Statements .. +C + SB02MS = DLAPY2( REIG, IEIG ).GE.ONE +C + RETURN +C *** Last line of SB02MS *** + END diff --git a/modules/cacsd/src/slicot/sb02ms.lo b/modules/cacsd/src/slicot/sb02ms.lo new file mode 100755 index 000000000..d22b30d21 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02ms.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02ms.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02ms.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02mt.f b/modules/cacsd/src/slicot/sb02mt.f new file mode 100755 index 000000000..2ccad1a11 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02mt.f @@ -0,0 +1,565 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To compute the following matrices +C +C -1 +C G = B*R *B', +C +C - -1 +C A = A - B*R *L', +C +C - -1 +C Q = Q - L*R *L', +C +C where A, B, Q, R, L, and G are N-by-N, N-by-M, N-by-N, M-by-M, +C N-by-M, and N-by-N matrices, respectively, with Q, R and G +C symmetric matrices. +C +C When R is well-conditioned with respect to inversion, standard +C algorithms for solving linear-quadratic optimization problems will +C then also solve optimization problems with coupling weighting +C matrix L. Moreover, a gain in efficiency is possible using matrix +C G in the deflating subspace algorithms (see SLICOT Library routine +C SB02OD). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBG CHARACTER*1 +C Specifies whether or not the matrix G is to be computed, +C as follows: +C = 'G': Compute G; +C = 'N': Do not compute G. +C +C JOBL CHARACTER*1 +C Specifies whether or not the matrix L is zero, as follows: +C = 'Z': L is zero; +C = 'N': L is nonzero. +C +C FACT CHARACTER*1 +C Specifies how the matrix R is given (factored or not), as +C follows: +C = 'N': Array R contains the matrix R; +C = 'C': Array R contains the Cholesky factor of R; +C = 'U': Array R contains the symmetric indefinite UdU' or +C LdL' factorization of R. +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices R and Q (if +C JOBL = 'N') is stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, Q, and G, and the number of +C rows of the matrices B and L. N >= 0. +C +C M (input) INTEGER +C The order of the matrix R, and the number of columns of +C the matrices B and L. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if JOBL = 'N', the leading N-by-N part of this +C array must contain the matrix A. +C On exit, if JOBL = 'N', and INFO = 0, the leading N-by-N +C - -1 +C part of this array contains the matrix A = A - B*R L'. +C If JOBL = 'Z', this array is not referenced. +C +C LDA INTEGER +C The leading dimension of array A. +C LDA >= MAX(1,N) if JOBL = 'N'; +C LDA >= 1 if JOBL = 'Z'. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix B. +C On exit, if OUFACT = 1, and INFO = 0, the leading N-by-M +C -1 +C part of this array contains the matrix B*chol(R) . +C On exit, B is unchanged if OUFACT = 2 (hence also when +C FACT = 'U'). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if JOBL = 'N', the leading N-by-N upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the upper +C triangular part or lower triangular part, respectively, of +C the symmetric matrix Q. The stricly lower triangular part +C (if UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C On exit, if JOBL = 'N' and INFO = 0, the leading N-by-N +C upper triangular part (if UPLO = 'U') or lower triangular +C part (if UPLO = 'L') of this array contains the upper +C triangular part or lower triangular part, respectively, of +C - -1 +C the symmetric matrix Q = Q - L*R *L'. +C If JOBL = 'Z', this array is not referenced. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,N) if JOBL = 'N'; +C LDQ >= 1 if JOBL = 'Z'. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry, if FACT = 'N', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the upper +C triangular part or lower triangular part, respectively, +C of the symmetric input weighting matrix R. +C On entry, if FACT = 'C', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the Cholesky +C factor of the positive definite input weighting matrix R +C (as produced by LAPACK routine DPOTRF). +C On entry, if FACT = 'U', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the factors of +C the UdU' or LdL' factorization, respectively, of the +C symmetric indefinite input weighting matrix R (as produced +C by LAPACK routine DSYTRF). +C If FACT = 'N', the stricly lower triangular part (if UPLO +C = 'U') or stricly upper triangular part (if UPLO = 'L') of +C this array is used as workspace. +C On exit, if OUFACT = 1, and INFO = 0 (or INFO = M+1), +C the leading M-by-M upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C contains the Cholesky factor of the given input weighting +C matrix. +C On exit, if OUFACT = 2, and INFO = 0 (or INFO = M+1), +C the leading M-by-M upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C contains the factors of the UdU' or LdL' factorization, +C respectively, of the given input weighting matrix. +C On exit R is unchanged if FACT = 'C' or 'U'. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C L (input/output) DOUBLE PRECISION array, dimension (LDL,M) +C On entry, if JOBL = 'N', the leading N-by-M part of this +C array must contain the matrix L. +C On exit, if JOBL = 'N', OUFACT = 1, and INFO = 0, the +C leading N-by-M part of this array contains the matrix +C -1 +C L*chol(R) . +C On exit, L is unchanged if OUFACT = 2 (hence also when +C FACT = 'U'). +C L is not referenced if JOBL = 'Z'. +C +C LDL INTEGER +C The leading dimension of array L. +C LDL >= MAX(1,N) if JOBL = 'N'; +C LDL >= 1 if JOBL = 'Z'. +C +C IPIV (input/output) INTEGER array, dimension (M) +C On entry, if FACT = 'U', this array must contain details +C of the interchanges performed and the block structure of +C the d factor in the UdU' or LdL' factorization of matrix R +C (as produced by LAPACK routine DSYTRF). +C On exit, if OUFACT = 2, this array contains details of +C the interchanges performed and the block structure of the +C d factor in the UdU' or LdL' factorization of matrix R, +C as produced by LAPACK routine DSYTRF. +C This array is not referenced if FACT = 'C'. +C +C OUFACT (output) INTEGER +C Information about the factorization finally used. +C OUFACT = 1: Cholesky factorization of R has been used; +C OUFACT = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = 'L') +C factorization of R has been used. +C +C G (output) DOUBLE PRECISION array, dimension (LDG,N) +C If JOBG = 'G', and INFO = 0, the leading N-by-N upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array contains the upper +C triangular part (if UPLO = 'U') or lower triangular part +C -1 +C (if UPLO = 'L'), respectively, of the matrix G = B*R B'. +C If JOBG = 'N', this array is not referenced. +C +C LDG INTEGER +C The leading dimension of array G. +C LDG >= MAX(1,N) if JOBG = 'G', +C LDG >= 1 if JOBG = 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; if FACT = 'N', DWORK(2) contains the reciprocal +C condition number of the given matrix R. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1 if FACT = 'C'; +C LDWORK >= MAX(2,3*M,N*M) if FACT = 'N'; +C LDWORK >= MAX(1,N*M) if FACT = 'U'. +C For optimum performance LDWORK should be larger than 3*M, +C if FACT = 'N'. +C The N*M workspace is not needed for FACT = 'N', if matrix +C R is positive definite. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if the i-th element (1 <= i <= M) of the d factor is +C exactly zero; the UdU' (or LdL') factorization has +C been completed, but the block diagonal matrix d is +C exactly singular; +C = M+1: if the matrix R is numerically singular. +C +C METHOD +C - - +C The matrices G, and/or A and Q are evaluated using the given or +C computed symmetric factorization of R. +C +C NUMERICAL ASPECTS +C +C The routine should not be used when R is ill-conditioned. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FACT, JOBG, JOBL, UPLO + INTEGER INFO, LDA, LDB, LDG, LDL, LDQ, LDR, LDWORK, M, + $ N, OUFACT +C .. Array Arguments .. + INTEGER IPIV(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), G(LDG,*), + $ L(LDL,*), Q(LDQ,*), R(LDR,*) +C .. Local Scalars .. + LOGICAL LFACTA, LFACTC, LFACTU, LJOBG, LJOBL, LUPLOU + CHARACTER TRANS + INTEGER I, J, WRKOPT + DOUBLE PRECISION EPS, RCOND, RNORM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DPOCON, DPOTRF, DSYCON, + $ DSYRK, DSYTRF, DSYTRS, DTRSM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 + LJOBG = LSAME( JOBG, 'G' ) + LJOBL = LSAME( JOBL, 'N' ) + LFACTC = LSAME( FACT, 'C' ) + LFACTU = LSAME( FACT, 'U' ) + LUPLOU = LSAME( UPLO, 'U' ) + LFACTA = LFACTC.OR.LFACTU +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBG .AND. .NOT.LSAME( JOBG, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( ( LDA.LT.1 ) .OR. ( LJOBL .AND. LDA.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( ( LDQ.LT.1 ) .OR. ( LJOBL .AND. LDQ.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDR.LT.MAX( 1, M ) ) THEN + INFO = -14 + ELSE IF( ( LDL.LT.1 ) .OR. ( LJOBL .AND. LDL.LT.N ) ) THEN + INFO = -16 + ELSE IF( ( LDG.LT.1 ) .OR. ( LJOBG .AND. LDG.LT.N ) ) THEN + INFO = -20 + ELSE IF( ( LFACTC .AND. LDWORK.LT.1 ) .OR. + $ ( LFACTU .AND. LDWORK.LT.MAX( 1, N*M ) ) .OR. + $ ( .NOT.LFACTA .AND. LDWORK.LT.MAX( 2, N*M, 3*M ) ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02MT', -INFO ) + RETURN + END IF +C + IF ( LFACTC ) THEN + OUFACT = 1 + ELSE IF ( LFACTU ) THEN + OUFACT = 2 + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 .OR. .NOT.( LJOBL.OR.LJOBG ) ) THEN + DWORK(1) = ONE + IF ( .NOT.LFACTA ) DWORK(2) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = 1 +C +C Set relative machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C + IF ( .NOT.LFACTA ) THEN +C +C Compute the norm of the matrix R, which is not factored. +C Then save the given triangle of R in the other strict triangle +C and the diagonal in the workspace, and try Cholesky +C factorization. +C Workspace: need M. +C + RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) + CALL DCOPY( M, R, LDR+1, DWORK, 1 ) + IF( LUPLOU ) THEN +C + DO 20 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 20 CONTINUE +C + ELSE +C + DO 40 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 40 CONTINUE +C + END IF + CALL DPOTRF( UPLO, M, R, LDR, INFO ) + IF( INFO.EQ.0 ) THEN +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 3*M. +C + CALL DPOCON( UPLO, M, R, LDR, RNORM, RCOND, DWORK, IWORK, + $ INFO ) +C +C Return if the matrix is singular to working precision. +C + OUFACT = 1 + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, 3*M ) + ELSE +C +C Use UdU' or LdL' factorization, first restoring the saved +C triangle. +C + CALL DCOPY( M, DWORK, 1, R, LDR+1 ) + IF( LUPLOU ) THEN +C + DO 60 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 60 CONTINUE +C + ELSE +C + DO 80 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 80 CONTINUE +C + END IF +C +C Compute the UdU' or LdL' factorization. +C Workspace: need 1, +C prefer M*NB. +C + CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) + OUFACT = 2 + IF( INFO.GT.0 ) THEN + DWORK(2) = ONE + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 2*M. +C + CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, + $ IWORK, INFO ) +C +C Return if the matrix is singular to working precision. +C + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + END IF + END IF +C + IF (OUFACT.EQ.1 ) THEN +C +C Solve positive definite linear system(s). +C + IF ( LUPLOU ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +C +C Solve the system X*U = B, overwriting B with X. +C + CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, + $ ONE, R, LDR, B, LDB ) +C + IF ( LJOBG ) THEN +C -1 +C Compute the matrix G = B*R *B', multiplying X*X' in G. +C + CALL DSYRK( UPLO, 'No transpose', N, M, ONE, B, LDB, ZERO, + $ G, LDG ) + END IF +C + IF( LJOBL ) THEN +C +C Update matrices A and Q. +C +C Solve the system Y*U = L, overwriting L with Y. +C + CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, + $ ONE, R, LDR, L, LDL ) +C +C Compute A <- A - X*Y'. +C + CALL DGEMM( 'No transpose', 'Transpose', N, N, M, -ONE, B, + $ LDB, L, LDL, ONE, A, LDA ) +C +C Compute Q <- Q - Y*Y'. +C + CALL DSYRK( UPLO, 'No transpose', N, M, -ONE, L, LDL, ONE, + $ Q, LDQ ) + END IF + ELSE +C +C Solve indefinite linear system(s). +C +C Solve the system UdU'*X = B' (or LdL'*X = B'). +C Workspace: need N*M. +C + DO 100 J = 1, M + CALL DCOPY( N, B(1,J), 1, DWORK(J), M ) + 100 CONTINUE +C + CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) +C + IF ( LJOBG ) THEN +C -1 +C Compute a triangle of the matrix G = B*R *B' = B*X. +C + IF ( LUPLOU ) THEN + I = 1 +C + DO 120 J = 1, N + CALL DGEMV( 'No transpose', J, M, ONE, B, LDB, + $ DWORK(I), 1, ZERO, G(1,J), 1 ) + I = I + M + 120 CONTINUE +C + ELSE +C + DO 140 J = 1, N + CALL DGEMV( 'Transpose', M, J, ONE, DWORK, M, B(J,1), + $ LDB, ZERO, G(J,1), LDG ) + 140 CONTINUE +C + END IF + END IF +C + IF( LJOBL ) THEN +C +C Update matrices A and Q. +C +C Solve the system UdU'*Y = L' (or LdL'*Y = L'). +C + DO 160 J = 1, M + CALL DCOPY( N, L(1,J), 1, DWORK(J), M ) + 160 CONTINUE +C + CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) +C +C A <- A - B*Y. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, M, -ONE, + $ B, LDB, DWORK, M, ONE, A, LDA ) +C - -1 +C Compute a triangle of the matrix Q = Q - L*R *L' = Q - L*Y. +C + IF ( LUPLOU ) THEN + I = 1 +C + DO 180 J = 1, N + CALL DGEMV( 'No transpose', J, M, -ONE, L, LDL, + $ DWORK(I), 1, ONE, Q(1,J), 1 ) + I = I + M + 180 CONTINUE +C + ELSE +C + DO 200 J = 1, N + CALL DGEMV( 'Transpose', M, J, -ONE, DWORK, M, L(J,1), + $ LDL, ONE, Q(J,1), LDQ ) + 200 CONTINUE +C + END IF + END IF + END IF +C + DWORK(1) = WRKOPT + IF ( .NOT.LFACTA ) DWORK(2) = RCOND +C +C *** Last line of SB02MT *** + RETURN + END diff --git a/modules/cacsd/src/slicot/sb02mt.lo b/modules/cacsd/src/slicot/sb02mt.lo new file mode 100755 index 000000000..d45bc2f38 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02mt.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02mt.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02mt.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02nd.f b/modules/cacsd/src/slicot/sb02nd.f new file mode 100755 index 000000000..8404bbe45 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02nd.f @@ -0,0 +1,739 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +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*1 DICO, FACT, JOBL, UPLO + INTEGER INFO, LDA, LDB, LDF, LDL, LDR, LDWORK, LDX, M, + $ N, P + DOUBLE PRECISION RNORM +C .. Array Arguments .. + INTEGER IPIV(*), IWORK(*), OUFACT(2) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), + $ L(LDL,*), R(LDR,*), X(LDX,*) +C .. Local Scalars .. + LOGICAL DISCR, LFACTA, LFACTC, LFACTD, LFACTU, LUPLOU, + $ WITHL + INTEGER I, IFAIL, ITAU, J, JW, JWORK, JZ, WRKOPT + DOUBLE PRECISION EPS, RCOND, RNORMP, TEMP +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DLASET, DPOCON, + $ DPOTRF, DPOTRS, DSCAL, DSYCON, DSYEV, DSYTRF, + $ DSYTRS, DTRCON, DTRMM, MB04KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LFACTC = LSAME( FACT, 'C' ) + LFACTD = LSAME( FACT, 'D' ) + LFACTU = LSAME( FACT, 'U' ) + LUPLOU = LSAME( UPLO, 'U' ) + WITHL = LSAME( JOBL, 'N' ) + LFACTA = LFACTC.OR.LFACTD.OR.LFACTU +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) .OR. + $ ( DISCR .AND. LFACTU ) ) THEN + INFO = -2 + ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( .NOT.WITHL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( ( .NOT.DISCR .AND. LDA.LT.1 ) .OR. + $ ( DISCR .AND. LDA.LT.MAX( 1, N ) ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( ( LDR.LT.MAX( 1, M ) ) .OR. + $ ( LFACTD .AND. LDR.LT.MAX( 1, P ) ) ) THEN + INFO = -13 + ELSE IF( ( .NOT.WITHL .AND. LDL.LT.1 ) .OR. + $ ( WITHL .AND. LDL.LT.MAX( 1, N ) ) ) THEN + INFO = -16 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LFACTU ) THEN + IF( RNORM.LT.ZERO ) + $ INFO = -19 + END IF + IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -21 + ELSE IF( ( ( .NOT.LFACTA .OR. ( LFACTC .AND. .NOT.DISCR ) ) + $ .AND. LDWORK.LT.MAX( 2, 3*M ) ) .OR. + $ ( LFACTU .AND. LDWORK.LT.MAX( 2, 2*M ) ) .OR. + $ ( DISCR .AND. LFACTC .AND. LDWORK.LT.N + 3*M + 2 ) .OR. + $(.NOT.DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( 2, MIN(P,M) + M ) ) + $ .OR. + $ ( DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( N + 3*M + 2, + $ 4*N + 1 ) ) ) THEN + INFO = -25 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 .OR. ( LFACTD .AND. P.EQ.0 ) ) THEN + DWORK(1) = ONE + DWORK(2) = ONE + RETURN + END IF +C + WRKOPT = 1 + EPS = DLAMCH( 'Epsilon' ) +C +C Determine the right-hand side of the matrix equation. +C Compute B'X in F. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + CALL DGEMM( 'Transpose', 'No transpose', M, N, N, ONE, B, LDB, X, + $ LDX, ZERO, F, LDF ) +C + IF ( .NOT.LFACTA ) THEN + IF ( DISCR ) THEN +C +C Discrete-time case with R not factored. Compute R + B'XB. +C + IF ( LUPLOU ) THEN +C + DO 10 J = 1, M + CALL DGEMV( 'No transpose', J, N, ONE, F, LDF, B(1,J), + $ 1, ONE, R(1,J), 1 ) + 10 CONTINUE +C + ELSE +C + DO 20 J = 1, M + CALL DGEMV( 'Transpose', N, J, ONE, B, LDB, F(J,1), + $ LDF, ONE, R(J,1), LDR ) + 20 CONTINUE +C + END IF + END IF +C +C Compute the 1-norm of the matrix R or R + B'XB. +C Workspace: need M. +C + RNORMP = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) + WRKOPT = MAX( WRKOPT, M ) + END IF +C + IF ( DISCR ) THEN +C +C For discrete-time case, postmultiply B'X by A. +C Workspace: need N. +C + DO 30 I = 1, M + CALL DCOPY( N, F(I,1), LDF, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, A, LDA, DWORK, 1, ZERO, + $ F(I,1), LDF ) + 30 CONTINUE +C + WRKOPT = MAX( WRKOPT, N ) + END IF +C + IF( WITHL ) THEN +C +C Add L'. +C + DO 50 I = 1, M +C + DO 40 J = 1, N + F(I,J) = F(I,J) + L(J,I) + 40 CONTINUE +C + 50 CONTINUE +C + END IF +C +C Solve the matrix equation. +C + IF ( LFACTA ) THEN +C +C Case 1: Matrix R is given in a factored form. +C + IF ( LFACTD ) THEN +C +C Use QR factorization of D. +C Workspace: need min(P,M) + M, +C prefer min(P,M) + M*NB. +C + ITAU = 1 + JWORK = ITAU + MIN( P, M ) + CALL DGEQRF( P, M, R, LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Make positive the diagonal elements of the triangular +C factor. Construct the strictly lower triangle, if requested. +C + DO 70 I = 1, M + IF ( R(I,I).LT.ZERO ) THEN +C + DO 60 J = I, M + R(I,J) = -R(I,J) + 60 CONTINUE +C + END IF + IF ( .NOT.LUPLOU ) + $ CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) + 70 CONTINUE +C + IF ( P.LT.M ) THEN + CALL DLASET( 'Full', M-P, M, ZERO, ZERO, R(P+1,1), LDR ) + IF ( .NOT.DISCR ) THEN + DWORK(2) = ZERO + INFO = M + 1 + RETURN + END IF + END IF + END IF +C + JW = 1 + IF ( DISCR ) THEN +C +C Discrete-time case. Update the factorization for B'XB. +C Try first the Cholesky factorization of X, saving the +C diagonal of X, in order to recover it, if X is not positive +C definite. In the later case, use spectral factorization. +C Workspace: need N. +C Define JW = 1 for Cholesky factorization of X, +C JW = N+3 for spectral factorization of X. +C + CALL DCOPY( N, X, LDX+1, DWORK, 1 ) + CALL DPOTRF( 'Upper', N, X, LDX, IFAIL ) + IF ( IFAIL.EQ.0 ) THEN +C +C Use Cholesky factorization of X to compute chol(X)*B. +C + OUFACT(2) = 1 + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non unit', + $ N, M, ONE, X, LDX, B, LDB ) + ELSE +C +C Use spectral factorization of X, X = UVU'. +C Workspace: need 4*N+1, +C prefer N*(NB+2)+N+2. +C + JW = N + 3 + OUFACT(2) = 2 + CALL DCOPY( N, DWORK, 1, X, LDX+1 ) + CALL DSYEV( 'Vectors', 'Lower', N, X, LDX, DWORK(3), + $ DWORK(JW), LDWORK-JW+1, IFAIL ) + IF ( IFAIL.GT.0 ) THEN + INFO = M + 2 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 ) + TEMP = ABS( DWORK(N+2) )*EPS +C +C Count the negligible eigenvalues and compute sqrt(V)U'B. +C Workspace: need 2*N+2. +C + JZ = 0 +C + 80 CONTINUE + IF ( ABS( DWORK(JZ+3) ).LE.TEMP ) THEN + JZ = JZ + 1 + IF ( JZ.LT.N) GO TO 80 + END IF +C + DO 90 J = 1, M + CALL DCOPY( N, B(1,J), 1, DWORK(JW), 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, X, LDX, DWORK(JW), + $ 1, ZERO, B(1,J), 1 ) + 90 CONTINUE +C + DO 100 I = JZ + 1, N + CALL DSCAL( M, SQRT( ABS( DWORK(I+2) ) ), B(I,1), LDB + $ ) + 100 CONTINUE +C + IF ( JZ.GT.0 ) + $ CALL DLASET( 'Full', JZ, M, ZERO, ZERO, B, LDB ) + END IF +C +C Update the triangular factorization. +C + IF ( .NOT.LUPLOU ) THEN +C +C For efficiency, use the transposed of the lower triangle. +C + DO 110 I = 2, M + CALL DCOPY( I-1, R(I,1), LDR, R(1,I), 1 ) + 110 CONTINUE +C + END IF +C +C Workspace: need JW+2*M-1. +C + CALL MB04KD( 'Full', M, 0, N, R, LDR, B, LDB, DUMMY, N, + $ DUMMY, M, DWORK(JW), DWORK(JW+N) ) + WRKOPT = MAX( WRKOPT, JW + 2*M - 1 ) +C +C Make positive the diagonal elements of the triangular +C factor. +C + DO 130 I = 1, M + IF ( R(I,I).LT.ZERO ) THEN +C + DO 120 J = I, M + R(I,J) = -R(I,J) + 120 CONTINUE +C + END IF + 130 CONTINUE +C + IF ( .NOT.LUPLOU ) THEN +C +C Construct the lower triangle. +C + DO 140 I = 2, M + CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) + 140 CONTINUE +C + END IF + END IF +C +C Compute the condition number of the coefficient matrix. +C + IF ( .NOT.LFACTU ) THEN +C +C Workspace: need JW+3*M-1. +C + CALL DTRCON( '1-norm', UPLO, 'Non unit', M, R, LDR, RCOND, + $ DWORK(JW), IWORK, IFAIL ) + OUFACT(1) = 1 + WRKOPT = MAX( WRKOPT, JW + 3*M - 1 ) + ELSE +C +C Workspace: need 2*M. +C + CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, + $ IWORK, INFO ) + OUFACT(1) = 2 + WRKOPT = MAX( WRKOPT, 2*M ) + END IF + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF +C + ELSE +C +C Case 2: Matrix R is given in an unfactored form. +C +C Save the given triangle of R or R + B'XB in the other +C strict triangle and the diagonal in the workspace, and try +C Cholesky factorization. +C Workspace: need M. +C + CALL DCOPY( M, R, LDR+1, DWORK, 1 ) + IF( LUPLOU ) THEN +C + DO 150 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 150 CONTINUE +C + ELSE +C + DO 160 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 160 CONTINUE +C + END IF + CALL DPOTRF( UPLO, M, R, LDR, INFO ) + OUFACT(1) = 1 + IF( INFO.EQ.0 ) THEN +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 3*M. +C + CALL DPOCON( UPLO, M, R, LDR, RNORMP, RCOND, DWORK, IWORK, + $ INFO ) +C +C Return if the matrix is singular to working precision. +C + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, 3*M ) + ELSE +C +C Use UdU' or LdL' factorization, first restoring the saved +C triangle. +C + CALL DCOPY( M, DWORK, 1, R, LDR+1 ) + IF( LUPLOU ) THEN +C + DO 170 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 170 CONTINUE +C + ELSE +C + DO 180 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 180 CONTINUE +C + END IF +C +C Workspace: need 1, +C prefer M*NB. +C + CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) + OUFACT(1) = 2 + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 2*M. +C + CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORMP, RCOND, DWORK, + $ IWORK, INFO ) +C +C Return if the matrix is singular to working precision. +C + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + END IF + END IF +C + IF (OUFACT(1).EQ.1 ) THEN +C +C Solve the positive definite linear system. +C + CALL DPOTRS( UPLO, M, N, R, LDR, F, LDF, INFO ) + ELSE +C +C Solve the indefinite linear system. +C + CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, F, LDF, INFO ) + END IF +C +C Set the optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB02ND *** + END diff --git a/modules/cacsd/src/slicot/sb02nd.lo b/modules/cacsd/src/slicot/sb02nd.lo new file mode 100755 index 000000000..24c63cb65 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02nd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02nd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02nd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02od.f b/modules/cacsd/src/slicot/sb02od.f new file mode 100755 index 000000000..f2ad5c14b --- /dev/null +++ b/modules/cacsd/src/slicot/sb02od.f @@ -0,0 +1,633 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +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 matrix A - BX, i.e. the stable eigenvalues +C lambda(1),...,lambda(N) of the corresponding Hamiltonian matrix. +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 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 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 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 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 - BX. 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 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. 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 +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', DWORK(2) returns the reciprocal +C of the condition number of the M-by-M lower triangular +C matrix obtained after compressing the (2N+M)-by-(2N+M) +C matrix pencil to obtain a 2N-by-2N pencil. +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 Error Indicator +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 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 +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. +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 The length of the workspace (LDWORK) was evaluated using the +C codes for LAPACK Library routine DGGES, not yet released. It +C appears that it is not large enough, when N is large. Setting, +C for instance, LDWORK = 1000*N could solve the problem. The +C SB02OD routine will be updated after the next release of LAPACK. +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. +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, 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 .. + LOGICAL DISCR, LFACB, LFACN, LFACQ, LFACR, LJOBB, LJOBL, + $ LSORT, LUPLO + INTEGER I, INFO1, J, LDW, NDIM, NN, NNM, NP1, WRKOPT + DOUBLE PRECISION RCONDL, UNORM +C .. External Functions .. + LOGICAL LSAME, SB02OU, SB02OV, SB02OW, SB02OX + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME, SB02OU, SB02OV, SB02OW, + $ SB02OX +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGECON, DGETRF, DGETRS, DGGES, + $ DLACPY, DLASET, DSCAL, SB02OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +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' ) + NN = 2*N + IF ( LJOBB ) THEN + LJOBL = LSAME( JOBL, 'Z' ) + 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.LSAME( JOBL, 'N' ) ) + $ 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( LJOBB ) THEN + IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.M .OR. + $ ( LFACR.OR.LFACB ) .AND. LDR.LT.P ) THEN + INFO = -17 + ELSE IF( ( .NOT.LJOBL .AND. LDL.LT.MAX( 1, N ) ) .OR. + $ ( LJOBL .AND. LDL.LT.1 ) ) 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.MAX( 1, NNM ) ) THEN + INFO = -29 + ELSE IF( LDU.LT.MAX( 1, NN ) ) THEN + INFO = -31 + ELSE IF( LDWORK.LT.MAX( 14*N + 23, 16*N, LDW ) ) THEN + INFO = -35 + 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 + DWORK(1) = ONE + RETURN + END IF +C +C Construct the extended matrix pair. +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 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 ) + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = U(1,1) + IF ( LJOBB ) RCONDL = U(2,1) +C +C Workspace: need max(7*(2*N+1)+16,16*N). +C + IF ( DISCR ) THEN + IF ( LSORT ) THEN + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OX, NN, S, + $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + 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 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 + 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 +C Make sure the solution matrix X is symmetric. +C + DO 40 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 ) + 40 CONTINUE + END IF +C + DWORK(1) = WRKOPT + IF ( LJOBB ) DWORK(2) = RCONDL +C + RETURN +C *** Last line of SB02OD *** + END diff --git a/modules/cacsd/src/slicot/sb02od.lo b/modules/cacsd/src/slicot/sb02od.lo new file mode 100755 index 000000000..66623aa04 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02od.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02od.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02od.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02ou.f b/modules/cacsd/src/slicot/sb02ou.f new file mode 100755 index 000000000..ac2d223f2 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02ou.f @@ -0,0 +1,67 @@ + LOGICAL FUNCTION SB02OU( ALPHAR, ALPHAI, BETA ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To select the unstable generalized eigenvalues for solving the +C continuous-time algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C ALPHAR (input) DOUBLE PRECISION +C The real part of the numerator of the current eigenvalue +C considered. +C +C ALPHAI (input) DOUBLE PRECISION +C The imaginary part of the numerator of the current +C eigenvalue considered. +C +C BETA (input) DOUBLE PRECISION +C The (real) denominator of the current eigenvalue +C considered. It is assumed that BETA <> 0 (regular case). +C +C METHOD +C +C The function value SB02OU is set to .TRUE. for an unstable +C eigenvalue and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02CW by P. Van Dooren, Philips +C Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHAR, ALPHAI, BETA +C .. Executable Statements .. +C + SB02OU = ( ALPHAR.LT.ZERO .AND. BETA.LT.ZERO ) .OR. + $ ( ALPHAR.GT.ZERO .AND. BETA.GT.ZERO ) +C + RETURN +C *** Last line of SB02OU *** + END diff --git a/modules/cacsd/src/slicot/sb02ou.lo b/modules/cacsd/src/slicot/sb02ou.lo new file mode 100755 index 000000000..3fb9d55ac --- /dev/null +++ b/modules/cacsd/src/slicot/sb02ou.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02ou.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02ou.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02ov.f b/modules/cacsd/src/slicot/sb02ov.f new file mode 100755 index 000000000..e8025db93 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02ov.f @@ -0,0 +1,72 @@ + LOGICAL FUNCTION SB02OV( ALPHAR, ALPHAI, BETA ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To select the unstable generalized eigenvalues for solving the +C discrete-time algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C ALPHAR (input) DOUBLE PRECISION +C The real part of the numerator of the current eigenvalue +C considered. +C +C ALPHAI (input) DOUBLE PRECISION +C The imaginary part of the numerator of the current +C eigenvalue considered. +C +C BETA (input) DOUBLE PRECISION +C The (real) denominator of the current eigenvalue +C considered. +C +C METHOD +C +C The function value SB02OV is set to .TRUE. for an unstable +C eigenvalue (i.e., with modulus greater than or equal to one) and +C to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips +C Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHAR, ALPHAI, BETA +C .. External Functions .. + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2 +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + SB02OV = DLAPY2( ALPHAR, ALPHAI ).GE.ABS( BETA ) +C + RETURN +C *** Last line of SB02OV *** + END diff --git a/modules/cacsd/src/slicot/sb02ov.lo b/modules/cacsd/src/slicot/sb02ov.lo new file mode 100755 index 000000000..fe87c18e9 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02ov.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02ov.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02ov.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02oy.f b/modules/cacsd/src/slicot/sb02oy.f new file mode 100755 index 000000000..9107d3368 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02oy.f @@ -0,0 +1,762 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +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 +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, 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 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 The leading 2N-by-2N part of this array contains the +C matrix B in the matrix pencil. +C f +C The last M zero columns are never constucted. +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'. +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 - +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( LDBF.LT.MAX( 1, NNM ) ) 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 +C Construct the first two block columns of BF. +C + IF ( LJOBE ) THEN + CALL DLASET( 'Full', N+NM, N, ZERO, ONE, BF, LDBF ) + ELSE + CALL DLACPY( 'Full', N, N, E, LDE, BF, LDBF ) + CALL DLASET( 'Full', NM, N, ZERO, ZERO, BF(NP1,1), LDBF ) + END IF +C + IF ( .NOT.DISCR.OR.LJOBB ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, BF(1,NP1), LDBF ) + ELSE + IF ( LUPLO ) THEN +C +C Construct (1,2) block of BF using the upper triangle of G. +C + DO 480 J = 1, N +C + DO 440 I = 1, J + BF(I,N+J)= B(I,J) + 440 CONTINUE +C + DO 460 I = J + 1, N + BF(I,N+J)= B(J,I) + 460 CONTINUE +C + 480 CONTINUE +C + ELSE +C +C Construct (1,2) block of BF using the lower triangle of G. +C + DO 540 J = 1, N +C + DO 500 I = 1, J - 1 + BF(I,N+J)= B(J,I) + 500 CONTINUE +C + DO 520 I = J, N + BF(I,N+J)= B(I,J) + 520 CONTINUE +C + 540 CONTINUE +C + END IF + END IF +C + IF ( DISCR ) THEN +C + DO 580 J = 1, N +C + DO 560 I = 1, N + BF(N+I,N+J)= -A(J,I) + 560 CONTINUE +C + 580 CONTINUE +C + IF ( LJOBB ) THEN +C + IF ( OPTC ) THEN +C + DO 620 J = 1, N +C + DO 600 I = 1, M + BF(N2+I,N+J)= -B(J,I) + 600 CONTINUE +C + 620 CONTINUE +C + ELSE +C + DO 660 J = 1, N +C + DO 640 I = 1, P + BF(N2+I,N+J) = -Q(I,J) + 640 CONTINUE +C + 660 CONTINUE +C + END IF + END IF +C + ELSE + IF ( LJOBE ) THEN + CALL DLASET( 'Full', NM, N, ZERO, -ONE, BF(NP1,NP1), LDBF ) + ELSE +C + DO 700 J = 1, N +C + DO 680 I = 1, N + BF(N+I,N+J)= -E(J,I) + 680 CONTINUE +C + 700 CONTINUE +C + IF ( LJOBB ) + $ CALL DLASET( 'Full', M, N, ZERO, ZERO, BF(N2P1,NP1), + $ LDBF ) + END IF + END IF +C + IF ( .NOT.LJOBB ) + $ RETURN +C +C Compress the pencil lambda x BF - AF, using QL factorization. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C +C Workspace: need 2*M; prefer M + M*NB. +C + ITAU = 1 + JWORK = ITAU + M + CALL DGEQLF( NNM, M, AF(1,N2P1), LDAF, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = DWORK(JWORK) +C +C Workspace: need 2*N+M; prefer M + 2*N*NB. +C + CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF, + $ DWORK(ITAU), AF, LDAF, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF, + $ DWORK(ITAU), BF, LDBF, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) +C +C Check the singularity of the L factor in the QL factorization: +C if singular, then the extended matrix pencil is also singular. +C Workspace 3*M. +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) + $ TOLDEF = DLAMCH( 'Epsilon' ) +C + CALL DTRCON( '1-norm', 'Lower', 'Non unit', M, AF(N2P1,N2P1), + $ LDAF, RCOND, DWORK, IWORK, INFO ) + WRKOPT = MAX( WRKOPT, 3*M ) +C + IF ( RCOND.LE.TOLDEF ) + $ INFO = 1 +C + DWORK(1) = WRKOPT + DWORK(2) = RCOND +C + RETURN +C *** Last line of SB02OY *** + END diff --git a/modules/cacsd/src/slicot/sb02oy.lo b/modules/cacsd/src/slicot/sb02oy.lo new file mode 100755 index 000000000..deda74e5a --- /dev/null +++ b/modules/cacsd/src/slicot/sb02oy.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02oy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02oy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02qd.f b/modules/cacsd/src/slicot/sb02qd.f new file mode 100755 index 000000000..f44b9732b --- /dev/null +++ b/modules/cacsd/src/slicot/sb02qd.f @@ -0,0 +1,785 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +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 - +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 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+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, SELECT1 + DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT1 +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEES, DLACON, DLACPY, 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', SELECT1, 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 ) +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 ) + 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 ) +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( LOUP, N, DWORK, N ) + END IF + GO TO 10 + END IF +C UNTIL KASE = 0 +C + IF( EST.LT.SCALE ) THEN + PINORM = EST / SCALE + ELSE + BIGNUM = ONE / DLAMCH( 'Safe minimum' ) + IF( EST.LT.SCALE*BIGNUM ) THEN + PINORM = EST / SCALE + ELSE + PINORM = BIGNUM + END IF + END IF +C +C Compute the 1-norm of A or T. +C + IF( UPDATE ) THEN + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + ELSE + ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) + END IF +C +C Compute the 1-norms of the matrices Q and G. +C + QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) + GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) +C +C Estimate the reciprocal condition number. +C + TMAX = MAX( SEP, XNORM, ANORM, GNORM ) + IF( TMAX.LE.ONE ) THEN + TEMP = SEP*XNORM + DENOM = QNORM + ( SEP*ANORM )*THNORM + + $ ( SEP*GNORM )*PINORM + ELSE + TEMP = ( SEP / TMAX )*( XNORM / TMAX ) + DENOM = ( ( ONE / TMAX )*( QNORM / TMAX ) ) + + $ ( ( SEP / TMAX )*( ANORM / TMAX ) )*THNORM + + $ ( ( SEP / TMAX )*( GNORM / TMAX ) )*PINORM + END IF + IF( TEMP.GE.DENOM ) THEN + RCOND = ONE + ELSE + RCOND = TEMP / DENOM + END IF + END IF +C + IF( .NOT.JOBC ) THEN +C +C Form a triangle of the residual matrix +C R = op(A)'*X + X*op(A) + Q - X*G*X, +C or _ _ _ _ _ _ +C R = op(T)'*X + X*op(T) + Q + X*G*X, +C exploiting the symmetry. +C Workspace 4*N*N. +C + IF( UPDATE ) THEN + CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N ) + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, ONE, + $ DWORK( IRES+1 ), N ) + SIG = -ONE + ELSE + CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, + $ DWORK( IRES+1 ), N, INFO2 ) + JJ = IRES + 1 + IF( LOWER ) THEN + DO 20 J = 1, N + CALL DAXPY( N-J+1, ONE, DWORK( JJ ), N, DWORK( JJ ), + $ 1 ) + CALL DAXPY( N-J+1, ONE, Q( J, J ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + 1 + 20 CONTINUE + ELSE + DO 30 J = 1, N + CALL DAXPY( J, ONE, DWORK( IRES+J ), N, DWORK( JJ ), + $ 1 ) + CALL DAXPY( J, ONE, Q( 1, J ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + 30 CONTINUE + END IF + SIG = ONE + END IF + CALL MB01RU( UPLO, TRANAT, N, N, ONE, SIG, DWORK( IRES+1 ), + $ N, X, LDX, G, LDG, DWORK( ITMP+1 ), NN, INFO2 ) +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) + EPSN = EPS*DBLE( N + 4 ) + TEMP = EPS*FOUR +C +C Add to abs(R) a term that takes account of rounding errors in +C forming R: +C abs(R) := abs(R) + EPS*(4*abs(Q) + (n+4)*(abs(op(Ac))'*abs(X) +C + abs(X)*abs(op(Ac))) + 2*(n+1)*abs(X)*abs(G)*abs(X)), +C or _ _ +C abs(R) := abs(R) + EPS*(4*abs(Q) + (n+4)*(abs(op(T))'*abs(X) +C _ _ _ _ +C + abs(X)*abs(op(T))) + 2*(n+1)*abs(X)*abs(G)*abs(X)), +C where EPS is the machine precision. +C + DO 50 J = 1, N + DO 40 I = 1, N + DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) + 40 CONTINUE + 50 CONTINUE +C + IF( LOWER ) THEN + DO 70 J = 1, N + DO 60 I = J, N + DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( Q( I, J ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 60 CONTINUE + 70 CONTINUE + ELSE + DO 90 J = 1, N + DO 80 I = 1, J + DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( Q( I, J ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 80 CONTINUE + 90 CONTINUE + END IF +C + IF( UPDATE ) THEN +C + DO 110 J = 1, N + DO 100 I = 1, N + DWORK( IABS+(J-1)*N+I ) = + $ ABS( DWORK( IABS+(J-1)*N+I ) ) + 100 CONTINUE + 110 CONTINUE +C + CALL DSYR2K( UPLO, TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, + $ DWORK( IXBS+1 ), N, ONE, DWORK( IRES+1 ), N ) + ELSE +C + DO 130 J = 1, N + DO 120 I = 1, MIN( J+1, N ) + DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) + 120 CONTINUE + 130 CONTINUE +C + CALL MB01UD( 'Left', TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, + $ DWORK( IXBS+1), N, DWORK( ITMP+1 ), N, INFO2 ) + JJ = IRES + 1 + JX = ITMP + 1 + IF( LOWER ) THEN + DO 140 J = 1, N + CALL DAXPY( N-J+1, ONE, DWORK( JX ), N, DWORK( JX ), + $ 1 ) + CALL DAXPY( N-J+1, ONE, DWORK( JX ), 1, DWORK( JJ ), + $ 1 ) + JJ = JJ + N + 1 + JX = JX + N + 1 + 140 CONTINUE + ELSE + DO 150 J = 1, N + CALL DAXPY( J, ONE, DWORK( ITMP+J ), N, DWORK( JX ), + $ 1 ) + CALL DAXPY( J, ONE, DWORK( JX ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + JX = JX + N + 150 CONTINUE + END IF + END IF +C + IF( LOWER ) THEN + DO 170 J = 1, N + DO 160 I = J, N + DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) + 160 CONTINUE + 170 CONTINUE + ELSE + DO 190 J = 1, N + DO 180 I = 1, J + DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) + 180 CONTINUE + 190 CONTINUE + END IF +C + CALL MB01RU( UPLO, TRANA, N, N, ONE, EPS*DBLE( 2*( N + 1 ) ), + $ DWORK( IRES+1 ), N, DWORK( IXBS+1), N, + $ DWORK( IABS+1 ), N, DWORK( ITMP+1 ), NN, INFO2 ) +C + WRKOPT = MAX( WRKOPT, 4*NN ) +C +C Compute forward error bound, using matrix norm estimator. +C Workspace 4*N*N. +C + XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) +C + CALL SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, + $ INFO ) + END IF +C + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of SB02QD *** + END diff --git a/modules/cacsd/src/slicot/sb02qd.lo b/modules/cacsd/src/slicot/sb02qd.lo new file mode 100755 index 000000000..4efd2196d --- /dev/null +++ b/modules/cacsd/src/slicot/sb02qd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02qd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02qd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02rd.f b/modules/cacsd/src/slicot/sb02rd.f new file mode 100755 index 000000000..262569016 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02rd.f @@ -0,0 +1,1094 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +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 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', 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 - +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 DLANSY + EXTERNAL 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( 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 + 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 +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 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 MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ, V, LDV, + $ Q, LDQ, DWORK(IW), NN, IERR ) + 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 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 + END IF +C + RETURN +C *** Last line of SB02RD *** + END diff --git a/modules/cacsd/src/slicot/sb02rd.lo b/modules/cacsd/src/slicot/sb02rd.lo new file mode 100755 index 000000000..171c30353 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02rd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02rd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02rd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02ru.f b/modules/cacsd/src/slicot/sb02ru.f new file mode 100755 index 000000000..4017b1b8a --- /dev/null +++ b/modules/cacsd/src/slicot/sb02ru.f @@ -0,0 +1,492 @@ + SUBROUTINE SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q, + $ LDQ, S, LDS, IWORK, DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To construct the 2n-by-2n Hamiltonian or symplectic matrix S +C associated to the linear-quadratic optimization problem, used to +C solve the continuous- or discrete-time algebraic Riccati equation, +C respectively. +C +C For a continuous-time problem, S is defined by +C +C ( op(A) -G ) +C S = ( ), (1) +C ( -Q -op(A)' ) +C +C and for a discrete-time problem by +C +C -1 -1 +C ( op(A) op(A) *G ) +C S = ( -1 -1 ), (2) +C ( Q*op(A) op(A)' + Q*op(A) *G ) +C +C or +C -T -T +C ( op(A) + G*op(A) *Q -G*op(A) ) +C S = ( -T -T ), (3) +C ( -op(A) *Q op(A) ) +C +C where op(A) = A or A' (A**T), A, G, and Q are n-by-n matrices, +C with G and Q symmetric. Matrix A must be nonsingular in the +C discrete-time case. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': Continuous-time system; +C = 'D': Discrete-time system. +C +C HINV CHARACTER*1 +C If DICO = 'D', specifies which of the matrices (2) or (3) +C is constructed, as follows: +C = 'D': The matrix S in (2) is constructed; +C = 'I': The (inverse) matrix S in (3) is constructed. +C HINV is not referenced if DICO = 'C'. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices G and Q is +C stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, and Q. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N upper triangular part (if +C UPLO = 'U') or lower triangular part (if UPLO = 'L') of +C this array must contain the upper triangular part or lower +C triangular part, respectively, of the symmetric matrix G. +C On exit, if DICO = 'D', the leading N-by-N part of this +C array contains the symmetric matrix G fully stored. +C If DICO = 'C', this array is not modified on exit, and the +C strictly lower triangular part (if UPLO = 'U') or strictly +C upper triangular part (if UPLO = 'L') is not referenced. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N upper triangular part (if +C UPLO = 'U') or lower triangular part (if UPLO = 'L') of +C this array must contain the upper triangular part or lower +C triangular part, respectively, of the symmetric matrix Q. +C On exit, if DICO = 'D', the leading N-by-N part of this +C array contains the symmetric matrix Q fully stored. +C If DICO = 'C', this array is not modified on exit, and the +C strictly lower triangular part (if UPLO = 'U') or strictly +C upper triangular part (if UPLO = 'L') is not referenced. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) +C If INFO = 0, the leading 2N-by-2N part of this array +C contains the Hamiltonian or symplectic matrix of the +C problem. +C +C LDS INTEGER +C The leading dimension of the array S. LDS >= MAX(1,2*N). +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK >= 0, if DICO = 'C'; +C LIWORK >= 2*N, if DICO = 'D'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if DICO = 'D', DWORK(1) returns the reciprocal +C condition number RCOND of the given matrix A, and +C DWORK(2) returns the reciprocal pivot growth factor +C norm(A)/norm(U) (see SLICOT Library routine MB02PD). +C If DWORK(2) is much less than 1, then the computed S +C and RCOND could be unreliable. If 0 < INFO <= N, then +C DWORK(2) contains the reciprocal pivot growth factor for +C the leading INFO columns of A. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 0, if DICO = 'C'; +C LDWORK >= MAX(2,6*N), if DICO = 'D'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if the leading i-by-i (1 <= i <= N) upper triangular +C submatrix of A is singular in discrete-time case; +C = N+1: if matrix A is numerically singular in discrete- +C time case. +C +C METHOD +C +C For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1) +C is constructed. +C For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or +C (3) - the inverse of the matrix in (2) - is constructed. +C +C NUMERICAL ASPECTS +C +C The discrete-time case needs the inverse of the matrix A, hence +C the routine should not be used when A is ill-conditioned. +C 3 +C The algorithm requires 0(n ) floating point operations in the +C discrete-time case. +C +C FURTHER COMMENTS +C +C This routine is a functionally extended and with improved accuracy +C version of the SLICOT Library routine SB02MU. Transposed problems +C can be dealt with as well. The LU factorization of op(A) (with +C no equilibration) and iterative refinement are used for solving +C the various linear algebraic systems involved. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, HINV, TRANA, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDS, LDWORK, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), + $ S(LDS,*) +C .. Local Scalars .. + CHARACTER EQUED, TRANAT + LOGICAL DISCR, LHINV, LUPLO, NOTRNA + INTEGER I, J, N2, NJ, NP1 + DOUBLE PRECISION PIVOTG, RCOND, RCONDA, TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLASET, DSWAP, MA02AD, + $ MA02ED, MB02PD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + N2 = N + N + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LUPLO = LSAME( UPLO, 'U' ) + NOTRNA = LSAME( TRANA, 'N' ) + IF( DISCR ) + $ LHINV = LSAME( HINV, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( DISCR ) THEN + IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) + $ INFO = -2 + ELSE IF( INFO.EQ.0 ) THEN + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) + $ .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN + INFO = -13 + ELSE IF( ( LDWORK.LT.0 ) .OR. + $ ( DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) ) THEN + INFO = -16 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02RU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( DISCR ) THEN + DWORK(1) = ONE + DWORK(2) = ONE + END IF + RETURN + END IF +C +C The code tries to exploit data locality as much as possible, +C assuming that LDS is greater than LDA, LDQ, and/or LDG. +C + IF ( .NOT.DISCR ) THEN +C +C Continuous-time case: Construct Hamiltonian matrix column-wise. +C +C Copy op(A) in S(1:N,1:N), and construct full Q +C in S(N+1:2*N,1:N) and change the sign. +C + DO 100 J = 1, N + IF ( NOTRNA ) THEN + CALL DCOPY( N, A(1,J), 1, S(1,J), 1 ) + ELSE + CALL DCOPY( N, A(J,1), LDA, S(1,J), 1 ) + END IF +C + IF ( LUPLO ) THEN +C + DO 20 I = 1, J + S(N+I,J) = -Q(I,J) + 20 CONTINUE +C + DO 40 I = J + 1, N + S(N+I,J) = -Q(J,I) + 40 CONTINUE +C + ELSE +C + DO 60 I = 1, J - 1 + S(N+I,J) = -Q(J,I) + 60 CONTINUE +C + DO 80 I = J, N + S(N+I,J) = -Q(I,J) + 80 CONTINUE +C + END IF + 100 CONTINUE +C +C Construct full G in S(1:N,N+1:2*N) and change the sign, and +C construct -op(A)' in S(N+1:2*N,N+1:2*N). +C + DO 240 J = 1, N + NJ = N + J + IF ( LUPLO ) THEN +C + DO 120 I = 1, J + S(I,NJ) = -G(I,J) + 120 CONTINUE +C + DO 140 I = J + 1, N + S(I,NJ) = -G(J,I) + 140 CONTINUE +C + ELSE +C + DO 160 I = 1, J - 1 + S(I,NJ) = -G(J,I) + 160 CONTINUE +C + DO 180 I = J, N + S(I,NJ) = -G(I,J) + 180 CONTINUE +C + END IF +C + IF ( NOTRNA ) THEN +C + DO 200 I = 1, N + S(N+I,NJ) = -A(J,I) + 200 CONTINUE +C + ELSE +C + DO 220 I = 1, N + S(N+I,NJ) = -A(I,J) + 220 CONTINUE +C + END IF + 240 CONTINUE +C + ELSE +C +C Discrete-time case: Construct the symplectic matrix (2) or (3). +C +C Fill in the remaining triangles of the symmetric matrices Q +C and G. +C + CALL MA02ED( UPLO, N, Q, LDQ ) + CALL MA02ED( UPLO, N, G, LDG ) +C +C Prepare the construction of S in (2) or (3). +C + NP1 = N + 1 + IF ( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C +C Solve op(A)'*X = Q in S(N+1:2*N,1:N), using the LU +C factorization of op(A), obtained in S(1:N,1:N), and +C iterative refinement. No equilibration of A is used. +C Workspace: 6*N. +C + CALL MB02PD( 'No equilibration', TRANAT, N, N, A, LDA, S, + $ LDS, IWORK, EQUED, DWORK, DWORK, Q, LDQ, + $ S(NP1,1), LDS, RCOND, DWORK, DWORK(NP1), + $ IWORK(NP1), DWORK(N2+1), INFO ) +C +C Return if the matrix is exactly singular or singular to +C working precision. +C + IF( INFO.GT.0 ) THEN + DWORK(1) = RCOND + DWORK(2) = DWORK(N2+1) + RETURN + END IF +C + RCONDA = RCOND + PIVOTG = DWORK(N2+1) +C + IF ( LHINV ) THEN +C +C Complete the construction of S in (2). +C +C Transpose X in-situ. +C + DO 260 J = 1, N - 1 + CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS ) + 260 CONTINUE +C +C Solve op(A)*X = I_n in S(N+1:2*N,N+1:2*N), using the LU +C factorization of op(A), computed in S(1:N,1:N), and +C iterative refinement. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS ) + CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, + $ EQUED, DWORK, DWORK, S(1,NP1), LDS, S(NP1,NP1), + $ LDS, RCOND, DWORK, DWORK(NP1), IWORK(NP1), + $ DWORK(N2+1), INFO ) +C +C Solve op(A)*X = G in S(1:N,N+1:2*N), using the LU +C factorization of op(A), computed in S(1:N,1:N), and +C iterative refinement. +C + CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, + $ EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS, + $ RCOND, DWORK, DWORK(NP1), IWORK(NP1), + $ DWORK(N2+1), INFO ) +C +C -1 +C Copy op(A) from S(N+1:2*N,N+1:2*N) in S(1:N,1:N). +C + CALL DLACPY( 'Full', N, N, S(NP1,NP1), LDS, S, LDS ) +C +C -1 +C Compute op(A)' + Q*op(A) *G in S(N+1:2*N,N+1:2*N). +C + IF ( NOTRNA ) THEN + CALL MA02AD( 'Full', N, N, A, LDA, S(NP1,NP1), LDS ) + ELSE + CALL DLACPY( 'Full', N, N, A, LDA, S(NP1,NP1), LDS ) + END IF + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ Q, LDQ, S(1,NP1), LDS, ONE, S(NP1,NP1), LDS ) +C + ELSE +C +C Complete the construction of S in (3). +C +C Change the sign of X. +C + DO 300 J = 1, N +C + DO 280 I = NP1, N2 + S(I,J) = -S(I,J) + 280 CONTINUE +C + 300 CONTINUE +C +C Solve op(A)'*X = I_n in S(N+1:2*N,N+1:2*N), using the LU +C factorization of op(A), computed in S(1:N,1:N), and +C iterative refinement. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS ) + CALL MB02PD( 'Factored', TRANAT, N, N, A, LDA, S, LDS, + $ IWORK, EQUED, DWORK, DWORK, S(1,NP1), LDS, + $ S(NP1,NP1), LDS, RCOND, DWORK, DWORK(NP1), + $ IWORK(NP1), DWORK(N2+1), INFO ) +C +C Solve op(A)*X' = -G in S(1:N,N+1:2*N), using the LU +C factorization of op(A), obtained in S(1:N,1:N), and +C iterative refinement. +C + CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, + $ EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS, + $ RCOND, DWORK, DWORK(NP1), IWORK(NP1), + $ DWORK(N2+1), INFO ) +C +C Change the sign of X and transpose it in-situ. +C + DO 340 J = NP1, N2 +C + DO 320 I = 1, N + TEMP = -S(I,J) + S(I,J) = -S(J-N,I+N) + S(J-N,I+N) = TEMP + 320 CONTINUE +C + 340 CONTINUE +C -T +C Compute op(A) + G*op(A) *Q in S(1:N,1:N). +C + IF ( NOTRNA ) THEN + CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) + ELSE + CALL MA02AD( 'Full', N, N, A, LDA, S, LDS ) + END IF + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, -ONE, + $ G, LDG, S(NP1,1), LDS, ONE, S, LDS ) +C + END IF + DWORK(1) = RCONDA + DWORK(2) = PIVOTG + END IF + RETURN +C +C *** Last line of SB02RU *** + END diff --git a/modules/cacsd/src/slicot/sb02ru.lo b/modules/cacsd/src/slicot/sb02ru.lo new file mode 100755 index 000000000..b24117da3 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02ru.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02ru.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02ru.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb02sd.f b/modules/cacsd/src/slicot/sb02sd.f new file mode 100755 index 000000000..f5c27fa2e --- /dev/null +++ b/modules/cacsd/src/slicot/sb02sd.f @@ -0,0 +1,840 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +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 - +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 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+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, SELECT1 + DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT1 +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEES, DGEMM, DGESV, DLACON, + $ DLACPY, DLASET, 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', SELECT1, 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 ) +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 ) + 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 ) +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( LOUP, N, DWORK, N ) + END IF + GO TO 30 + END IF +C UNTIL KASE = 0 +C + IF( EST.LT.SCALE ) THEN + PINORM = EST / SCALE + ELSE + BIGNUM = ONE / DLAMCH( 'Safe minimum' ) + IF( EST.LT.SCALE*BIGNUM ) THEN + PINORM = EST / SCALE + ELSE + PINORM = BIGNUM + END IF + END IF +C +C Compute the 1-norm of A or T. +C + IF( UPDATE ) THEN + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + ELSE + ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) + END IF +C +C Compute the 1-norms of the matrices Q and G. +C + QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) + GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) +C +C Estimate the reciprocal condition number. +C + TMAX = MAX( SEPD, XNORM, ANORM, GNORM ) + IF( TMAX.LE.ONE ) THEN + TEMP = SEPD*XNORM + DENOM = QNORM + ( SEPD*ANORM )*THNORM + + $ ( SEPD*GNORM )*PINORM + ELSE + TEMP = ( SEPD / TMAX )*( XNORM / TMAX ) + DENOM = ( ( ONE / TMAX )*( QNORM / TMAX ) ) + + $ ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM + + $ ( ( SEPD / TMAX )*( GNORM / TMAX ) )*PINORM + END IF + IF( TEMP.GE.DENOM ) THEN + RCOND = ONE + ELSE + RCOND = TEMP / DENOM + END IF + END IF +C + IF( .NOT.JOBC ) THEN +C +C Form a triangle of the residual matrix +C R = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q - X, +C or _ _ _ _ _ _ +C R = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q - X, +C exploiting the symmetry. Actually, the equivalent formula +C R = op(A)'*X*op(Ac) + Q - X +C is used in the first case. +C Workspace MAX(3,2*N*N) + 2*N*N, if LYAPUN = 'O'; +C MAX(3,2*N*N) + 2*N*N + N, if LYAPUN = 'R'. +C + CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N ) + JJ = IRES + 1 + IF( LOWER ) THEN + DO 40 J = 1, N + CALL DAXPY( N-J+1, -ONE, X( J, J ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + 1 + 40 CONTINUE + ELSE + DO 50 J = 1, N + CALL DAXPY( J, -ONE, X( 1, J ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + 50 CONTINUE + END IF +C + IF( UPDATE ) THEN + CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, ONE, + $ DWORK( IRES+1 ), N, A, LDA, DWORK( IXMA+1 ), N, + $ INFO2 ) + ELSE + CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, ONE, + $ DWORK( IRES+1 ), N, T, LDT, DWORK( IXMA+1 ), N, + $ DWORK( IWRK+1 ), INFO2 ) + CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, + $ DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N ) + CALL MB01RX( 'Left', UPLO, 'Transpose', N, N, ONE, ONE, + $ DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N, + $ DWORK( IXBS+1 ), N, INFO2 ) + END IF +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) + EPSN = EPS*DBLE( N + 4 ) + EPST = EPS*DBLE( 2*( N + 1 ) ) + TEMP = EPS*FOUR +C +C Add to abs(R) a term that takes account of rounding errors in +C forming R: +C abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) + +C (n+4)*abs(op(Ac))'*abs(X)*abs(op(Ac)) + 2*(n+1)* +C abs(op(Ac))'*abs(X)*abs(G)*abs(X)*abs(op(Ac))), +C or _ _ +C abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) + +C _ +C (n+4)*abs(op(T))'*abs(X)*abs(op(T)) + +C _ _ _ +C 2*(n+1)*abs(op(T))'*abs(X)*abs(G)*abs(X)*abs(op(T))), +C where EPS is the machine precision. +C + DO 70 J = 1, N + DO 60 I = 1, N + DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) + 60 CONTINUE + 70 CONTINUE +C + IF( LOWER ) THEN + DO 90 J = 1, N + DO 80 I = J, N + DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) + + $ ABS( X( I, J ) ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 80 CONTINUE + 90 CONTINUE + ELSE + DO 110 J = 1, N + DO 100 I = 1, J + DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) + + $ ABS( X( I, J ) ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 100 CONTINUE + 110 CONTINUE + END IF +C + IF( UPDATE ) THEN +C + DO 130 J = 1, N + DO 120 I = 1, N + DWORK( IABS+(J-1)*N+I ) = + $ ABS( DWORK( IABS+(J-1)*N+I ) ) + 120 CONTINUE + 130 CONTINUE +C + CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, + $ DWORK( IXBS+1 ), N, DWORK( IABS+1 ), N, ZERO, + $ DWORK( IXMA+1 ), N ) + CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, EPSN, + $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, + $ DWORK( IXMA+1 ), N, INFO2 ) + ELSE +C + DO 150 J = 1, N + DO 140 I = 1, MIN( J+1, N ) + DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) + 140 CONTINUE + 150 CONTINUE +C + CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N, + $ DWORK( IXBS+1 ), N, DWORK( IXMA+1 ), N, INFO2 ) + CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN, + $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, + $ DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), INFO2 ) + END IF +C + IF( LOWER ) THEN + DO 170 J = 1, N + DO 160 I = J, N + DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) + 160 CONTINUE + 170 CONTINUE + ELSE + DO 190 J = 1, N + DO 180 I = 1, J + DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) + 180 CONTINUE + 190 CONTINUE + END IF +C + IF( UPDATE ) THEN + CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPST, DWORK( IRES+1 ), + $ N, DWORK( IXMA+1 ), N, DWORK( IABS+1 ), N, + $ DWORK( IXBS+1 ), NN, INFO2 ) + WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN ) + ELSE + CALL DSYMM( 'Left', UPLO, N, N, ONE, DWORK( IABS+1 ), N, + $ DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N ) + CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPST, + $ DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N, + $ DWORK( IXBS+1 ), N, DWORK( IWRK+1 ), INFO2 ) + WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN + N ) + END IF +C +C Compute forward error bound, using matrix norm estimator. +C Workspace MAX(3,2*N*N) + N*N. +C + XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) +C + CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK( IXBS+1 ), + $ IXMA, INFO ) + END IF +C + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of SB02SD *** + END diff --git a/modules/cacsd/src/slicot/sb02sd.lo b/modules/cacsd/src/slicot/sb02sd.lo new file mode 100755 index 000000000..60b3c68d3 --- /dev/null +++ b/modules/cacsd/src/slicot/sb02sd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb02sd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb02sd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03md.f b/modules/cacsd/src/slicot/sb03md.f new file mode 100755 index 000000000..619f33e2d --- /dev/null +++ b/modules/cacsd/src/slicot/sb03md.f @@ -0,0 +1,540 @@ + SUBROUTINE SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C, + $ LDC, SCALE, SEP, FERR, WR, WI, IWORK, DWORK, + $ LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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, SELECT1 + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS, LSAME, SELECT1 +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', SELECT1, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + LWA = INT( DWORK( 1 ) ) + END IF +C + IF( .NOT.WANTSP ) THEN +C +C Transform the right-hand side. +C Workspace: N*N. +C + NTRNST = 'N' + TRANST = 'T' + UPLO = 'U' + CALL MB01RD( UPLO, TRANST, N, N, ZERO, ONE, C, LDC, U, LDU, C, + $ LDC, DWORK, LDWORK, INFO ) +C + DO 10 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 10 CONTINUE +C + LWA = MAX( LWA, NN ) +C +C Solve the transformed equation. +C Workspace for DICO = 'D': 2*N. +C + IF ( CONT ) THEN + CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) + ELSE + CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) + END IF + IF( INFO.GT.0 ) + $ INFO = N + 1 +C +C Transform back the solution. +C Workspace: N*N. +C + CALL MB01RD( UPLO, NTRNST, N, N, ZERO, ONE, C, LDC, U, LDU, C, + $ LDC, DWORK, LDWORK, IERR ) +C + DO 20 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 20 CONTINUE +C + END IF +C + IF( .NOT.WANTX ) THEN +C +C Estimate the separation. +C Workspace: 2*N*N for DICO = 'C'; +C 2*N*N + 2*N for DICO = 'D'. +C + IF( NOTA ) THEN + NOTRA = 'T' + ELSE + NOTRA = 'N' + END IF +C + EST = ZERO + KASE = 0 +C REPEAT + 30 CONTINUE + CALL DLACON( NN, DWORK(NN+1), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN + IF( CONT ) THEN + CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, + $ IERR ) + ELSE + CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK(NN2+1), IERR ) + END IF + ELSE + IF( CONT ) THEN + CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, + $ IERR ) + ELSE + CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK(NN2+1), IERR ) + END IF + END IF + GO TO 30 + END IF +C UNTIL KASE = 0 +C + SEP = SCALEF / EST +C + IF( WANTBH ) THEN +C +C Get the machine precision. +C + EPS = DLAMCH( 'P' ) +C +C Compute the estimate of the relative error. +C + IF ( CONT ) THEN + FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )/SEP + ELSE + FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )**2/SEP + END IF + END IF + END IF +C + DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) + RETURN +C *** Last line of SB03MD *** + END diff --git a/modules/cacsd/src/slicot/sb03md.lo b/modules/cacsd/src/slicot/sb03md.lo new file mode 100755 index 000000000..2abd6cd08 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03md.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03md.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03md.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03mv.f b/modules/cacsd/src/slicot/sb03mv.f new file mode 100755 index 000000000..c69a158eb --- /dev/null +++ b/modules/cacsd/src/slicot/sb03mv.f @@ -0,0 +1,279 @@ + SUBROUTINE SB03MV( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, + $ XNORM, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve for the 2-by-2 symmetric matrix X in +C +C op(T)'*X*op(T) - X = SCALE*B, +C +C where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T', +C where T' denotes the transpose of T. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRAN LOGICAL +C Specifies the form of op(T) to be used, as follows: +C = .FALSE.: op(T) = T, +C = .TRUE. : op(T) = T'. +C +C LUPPER LOGICAL +C Specifies which triangle of the matrix B is used, and +C which triangle of the matrix X is computed, as follows: +C = .TRUE. : The upper triangular part; +C = .FALSE.: The lower triangular part. +C +C Input/Output Parameters +C +C T (input) DOUBLE PRECISION array, dimension (LDT,2) +C The leading 2-by-2 part of this array must contain the +C matrix T. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= 2. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,2) +C On entry with LUPPER = .TRUE., the leading 2-by-2 upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix B and the strictly +C lower triangular part of B is not referenced. +C On entry with LUPPER = .FALSE., the leading 2-by-2 lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix B and the strictly +C upper triangular part of B is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= 2. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor. SCALE is chosen less than or equal to 1 +C to prevent the solution overflowing. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,2) +C On exit with LUPPER = .TRUE., the leading 2-by-2 upper +C triangular part of this array contains the upper +C triangular part of the symmetric solution matrix X and the +C strictly lower triangular part of X is not referenced. +C On exit with LUPPER = .FALSE., the leading 2-by-2 lower +C triangular part of this array contains the lower +C triangular part of the symmetric solution matrix X and the +C strictly upper triangular part of X is not referenced. +C Note that X may be identified with B in the calling +C statement. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= 2. +C +C XNORM (output) DOUBLE PRECISION +C The infinity-norm of the solution. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if T has almost reciprocal eigenvalues, so T +C is perturbed to get a nonsingular equation. +C +C NOTE: In the interests of speed, this routine does not +C check the inputs for errors. +C +C METHOD +C +C The equivalent linear algebraic system of equations is formed and +C solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Based on DLALD2 by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, Lyapunov equation, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0 ) +C .. +C .. Scalar Arguments .. + LOGICAL LTRAN, LUPPER + INTEGER INFO, LDB, LDT, LDX + DOUBLE PRECISION SCALE, XNORM +C .. +C .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) +C .. +C .. Local Scalars .. + INTEGER I, IP, IPSV, J, JP, JPSV, K + DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX +C .. +C .. Local Arrays .. + INTEGER JPIV( 3 ) + DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Executable Statements .. +C +C Do not check the input parameters for errors. +C + INFO = 0 +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS +C +C Solve equivalent 3-by-3 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + SMIN = MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), + $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) ) + SMIN = MAX( EPS*SMIN, SMLNUM ) + T9( 1, 1 ) = T( 1, 1 )*T( 1, 1 ) - ONE + T9( 2, 2 ) = T( 1, 1 )*T( 2, 2 ) + T( 1, 2 )*T( 2, 1 ) - ONE + T9( 3, 3 ) = T( 2, 2 )*T( 2, 2 ) - ONE + IF( LTRAN ) THEN + T9( 1, 2 ) = T( 1, 1 )*T( 1, 2 ) + T( 1, 1 )*T( 1, 2 ) + T9( 1, 3 ) = T( 1, 2 )*T( 1, 2 ) + T9( 2, 1 ) = T( 1, 1 )*T( 2, 1 ) + T9( 2, 3 ) = T( 1, 2 )*T( 2, 2 ) + T9( 3, 1 ) = T( 2, 1 )*T( 2, 1 ) + T9( 3, 2 ) = T( 2, 1 )*T( 2, 2 ) + T( 2, 1 )*T( 2, 2 ) + ELSE + T9( 1, 2 ) = T( 1, 1 )*T( 2, 1 ) + T( 1, 1 )*T( 2, 1 ) + T9( 1, 3 ) = T( 2, 1 )*T( 2, 1 ) + T9( 2, 1 ) = T( 1, 1 )*T( 1, 2 ) + T9( 2, 3 ) = T( 2, 1 )*T( 2, 2 ) + T9( 3, 1 ) = T( 1, 2 )*T( 1, 2 ) + T9( 3, 2 ) = T( 1, 2 )*T( 2, 2 ) + T( 1, 2 )*T( 2, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + IF ( LUPPER ) THEN + BTMP( 2 ) = B( 1, 2 ) + ELSE + BTMP( 2 ) = B( 2, 1 ) + END IF + BTMP( 3 ) = B( 2, 2 ) +C +C Perform elimination. +C + DO 50 I = 1, 2 + XMAX = ZERO +C + DO 20 IP = I, 3 +C + DO 10 JP = I, 3 + IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T9( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 10 CONTINUE +C + 20 CONTINUE +C + IF( IPSV.NE.I ) THEN + CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T9( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T9( I, I ) = SMIN + END IF +C + DO 40 J = I + 1, 3 + T9( J, I ) = T9( J, I ) / T9( I, I ) + BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) +C + DO 30 K = I + 1, 3 + T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) + 30 CONTINUE +C + 40 CONTINUE +C + 50 CONTINUE +C + IF( ABS( T9( 3, 3 ) ).LT.SMIN ) + $ T9( 3, 3 ) = SMIN + SCALE = ONE + IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR. + $ ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR. + $ ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN + SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + END IF +C + DO 70 I = 1, 3 + K = 4 - I + TEMP = ONE / T9( K, K ) + TMP( K ) = BTMP( K )*TEMP +C + DO 60 J = K + 1, 3 + TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) + 60 CONTINUE +C + 70 CONTINUE +C + DO 80 I = 1, 2 + IF( JPIV( 3-I ).NE.3-I ) THEN + TEMP = TMP( 3-I ) + TMP( 3-I ) = TMP( JPIV( 3-I ) ) + TMP( JPIV( 3-I ) ) = TEMP + END IF + 80 CONTINUE +C + X( 1, 1 ) = TMP( 1 ) + IF ( LUPPER ) THEN + X( 1, 2 ) = TMP( 2 ) + ELSE + X( 2, 1 ) = TMP( 2 ) + END IF + X( 2, 2 ) = TMP( 3 ) + XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ), + $ ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) ) +C + RETURN +C *** Last line of SB03MV *** + END diff --git a/modules/cacsd/src/slicot/sb03mv.lo b/modules/cacsd/src/slicot/sb03mv.lo new file mode 100755 index 000000000..11ca2377e --- /dev/null +++ b/modules/cacsd/src/slicot/sb03mv.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03mv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03mv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03mw.f b/modules/cacsd/src/slicot/sb03mw.f new file mode 100755 index 000000000..ea1a53a5f --- /dev/null +++ b/modules/cacsd/src/slicot/sb03mw.f @@ -0,0 +1,277 @@ + SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, + $ XNORM, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve for the 2-by-2 symmetric matrix X in +C +C op(T)'*X + X*op(T) = SCALE*B, +C +C where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T', +C where T' denotes the transpose of T. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRAN LOGICAL +C Specifies the form of op(T) to be used, as follows: +C = .FALSE.: op(T) = T, +C = .TRUE. : op(T) = T'. +C +C LUPPER LOGICAL +C Specifies which triangle of the matrix B is used, and +C which triangle of the matrix X is computed, as follows: +C = .TRUE. : The upper triangular part; +C = .FALSE.: The lower triangular part. +C +C Input/Output Parameters +C +C T (input) DOUBLE PRECISION array, dimension (LDT,2) +C The leading 2-by-2 part of this array must contain the +C matrix T. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= 2. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,2) +C On entry with LUPPER = .TRUE., the leading 2-by-2 upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix B and the strictly +C lower triangular part of B is not referenced. +C On entry with LUPPER = .FALSE., the leading 2-by-2 lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix B and the strictly +C upper triangular part of B is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= 2. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor. SCALE is chosen less than or equal to 1 +C to prevent the solution overflowing. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,2) +C On exit with LUPPER = .TRUE., the leading 2-by-2 upper +C triangular part of this array contains the upper +C triangular part of the symmetric solution matrix X and the +C strictly lower triangular part of X is not referenced. +C On exit with LUPPER = .FALSE., the leading 2-by-2 lower +C triangular part of this array contains the lower +C triangular part of the symmetric solution matrix X and the +C strictly upper triangular part of X is not referenced. +C Note that X may be identified with B in the calling +C statement. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= 2. +C +C XNORM (output) DOUBLE PRECISION +C The infinity-norm of the solution. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if T and -T have too close eigenvalues, so T +C is perturbed to get a nonsingular equation. +C +C NOTE: In the interests of speed, this routine does not +C check the inputs for errors. +C +C METHOD +C +C The equivalent linear algebraic system of equations is formed and +C solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Based on DLALY2 by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Continuous-time system, Lyapunov equation, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0 ) +C .. +C .. Scalar Arguments .. + LOGICAL LTRAN, LUPPER + INTEGER INFO, LDB, LDT, LDX + DOUBLE PRECISION SCALE, XNORM +C .. +C .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) +C .. +C .. Local Scalars .. + INTEGER I, IP, IPSV, J, JP, JPSV, K + DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX +C .. +C .. Local Arrays .. + INTEGER JPIV( 3 ) + DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Executable Statements .. +C +C Do not check the input parameters for errors +C + INFO = 0 +C +C Set constants to control overflow +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS +C +C Solve equivalent 3-by-3 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + SMIN = MAX( MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), + $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) )*EPS, + $ SMLNUM ) + T9( 1, 3 ) = ZERO + T9( 3, 1 ) = ZERO + T9( 1, 1 ) = T( 1, 1 ) + T9( 2, 2 ) = T( 1, 1 ) + T( 2, 2 ) + T9( 3, 3 ) = T( 2, 2 ) + IF( LTRAN ) THEN + T9( 1, 2 ) = T( 1, 2 ) + T9( 2, 1 ) = T( 2, 1 ) + T9( 2, 3 ) = T( 1, 2 ) + T9( 3, 2 ) = T( 2, 1 ) + ELSE + T9( 1, 2 ) = T( 2, 1 ) + T9( 2, 1 ) = T( 1, 2 ) + T9( 2, 3 ) = T( 2, 1 ) + T9( 3, 2 ) = T( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 )/TWO + IF ( LUPPER ) THEN + BTMP( 2 ) = B( 1, 2 ) + ELSE + BTMP( 2 ) = B( 2, 1 ) + END IF + BTMP( 3 ) = B( 2, 2 )/TWO +C +C Perform elimination +C + DO 50 I = 1, 2 + XMAX = ZERO +C + DO 20 IP = I, 3 +C + DO 10 JP = I, 3 + IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T9( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 10 CONTINUE +C + 20 CONTINUE +C + IF( IPSV.NE.I ) THEN + CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T9( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T9( I, I ) = SMIN + END IF +C + DO 40 J = I + 1, 3 + T9( J, I ) = T9( J, I ) / T9( I, I ) + BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) +C + DO 30 K = I + 1, 3 + T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) + 30 CONTINUE +C + 40 CONTINUE +C + 50 CONTINUE +C + IF( ABS( T9( 3, 3 ) ).LT.SMIN ) + $ T9( 3, 3 ) = SMIN + SCALE = ONE + IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR. + $ ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR. + $ ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN + SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + END IF +C + DO 70 I = 1, 3 + K = 4 - I + TEMP = ONE / T9( K, K ) + TMP( K ) = BTMP( K )*TEMP +C + DO 60 J = K + 1, 3 + TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) + 60 CONTINUE +C + 70 CONTINUE +C + DO 80 I = 1, 2 + IF( JPIV( 3-I ).NE.3-I ) THEN + TEMP = TMP( 3-I ) + TMP( 3-I ) = TMP( JPIV( 3-I ) ) + TMP( JPIV( 3-I ) ) = TEMP + END IF + 80 CONTINUE +C + X( 1, 1 ) = TMP( 1 ) + IF ( LUPPER ) THEN + X( 1, 2 ) = TMP( 2 ) + ELSE + X( 2, 1 ) = TMP( 2 ) + END IF + X( 2, 2 ) = TMP( 3 ) + XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ), + $ ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) ) +C + RETURN +C *** Last line of SB03MW *** + END diff --git a/modules/cacsd/src/slicot/sb03mw.lo b/modules/cacsd/src/slicot/sb03mw.lo new file mode 100755 index 000000000..8bceb3a08 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03mw.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03mw.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03mw.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03mx.f b/modules/cacsd/src/slicot/sb03mx.f new file mode 100755 index 000000000..f64502d2b --- /dev/null +++ b/modules/cacsd/src/slicot/sb03mx.f @@ -0,0 +1,692 @@ + SUBROUTINE SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 +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 + 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 ) +C + KNEXT = L +C + DO 110 K = L, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 110 + K1 = K + K2 = K + IF( K.GT.1 ) THEN + IF( A( K, K-1 ).NE.ZERO ) + $ K1 = K1 - 1 + KNEXT = K1 - 1 + END IF + MINK1N = MIN( K1+1, N ) + MINK2N = MIN( K2+1, N ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + DWORK( K1 ) = DDOT( N-L1, C( K1, MINL1N ), LDC, + $ A( L1, MINL1N ), LDA ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( N-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) + $ + DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L1 ), 1 )*A( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*A( L1, L1 ) - ONE + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 70 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + END IF +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + DWORK( K1 ) = DDOT( N-L1, C( K1, MINL1N ), LDC, + $ A( L1, MINL1N ), LDA ) + DWORK( K2 ) = DDOT( N-L1, C( K2, MINL1N ), LDC, + $ A( L1, MINL1N ), LDA ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) + $ + DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 )*A( L1, L1 ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( K1 ), 1 ) + $ + DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 )*A( L1, L1 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, A( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, ONE, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 80 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 80 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L1, K2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + DWORK( K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) + DWORK( N+K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) + P11 = DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L1 ), 1 ) + P12 = DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L2 ), 1 ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) + $ + P11*A( L1, L1 ) + P12*A( L1, L2 ) ) +C + VEC( 2, 1 ) = C( K1, L2 ) - + $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( N+K1 ), 1) + $ + P11*A( L2, L1 ) + P12*A( L2, L2 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), + $ A( L1, L1 ), LDA, ONE, ONE, VEC, 2, ONE, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 90 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 90 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + DWORK( K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) + DWORK( K2 ) = DDOT( N-L2, C( K2, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) + DWORK( N+K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) + DWORK( N+K2 ) = DDOT( N-L2, C( K2, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) + P11 = DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + P12 = DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L2 ), 1 ) + P21 = DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + P22 = DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L2 ), 1 ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) + $ + P11*A( L1, L1 ) + P12*A( L1, L2 ) ) +C + VEC( 1, 2 ) = C( K1, L2 ) - + $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( N+K1 ), + $ 1) + P11*A( L2, L1 ) + P12*A( L2, L2 ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1) + P21*A( L1, L1 ) + P22*A( L1, L2 ) ) +C + VEC( 2, 2 ) = C( K2, L2 ) - + $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( N+K1 ), 1) + $ + P21*A( L2, L1 ) + P22*A( L2, L2 ) ) +C + IF( K1.EQ.L1 ) THEN + CALL SB03MV( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC, + $ 2, SCALOC, X, 2, XNORM, IERR ) + IF( LUPPER ) THEN + X( 2, 1 ) = X( 1, 2 ) + ELSE + X( 1, 2 ) = X( 2, 1 ) + END IF + ELSE + CALL SB04PX( .FALSE., .TRUE., -1, 2, 2, + $ A( K1, K1 ), LDA, A( L1, L1 ), LDA, + $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) + END IF + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 100 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 1, 2 ) + C( L1, K2 ) = X( 2, 1 ) + C( L2, K2 ) = X( 2, 2 ) + END IF + END IF +C + 110 CONTINUE +C + 120 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB03MX *** + END diff --git a/modules/cacsd/src/slicot/sb03mx.lo b/modules/cacsd/src/slicot/sb03mx.lo new file mode 100755 index 000000000..19ba12817 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03mx.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03mx.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03mx.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03my.f b/modules/cacsd/src/slicot/sb03my.f new file mode 100755 index 000000000..75ffd45da --- /dev/null +++ b/modules/cacsd/src/slicot/sb03my.f @@ -0,0 +1,597 @@ + SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve the real Lyapunov matrix equation +C +C op(A)'*X + X*op(A) = scale*C +C +C where op(A) = A or A' (A**T), A is upper quasi-triangular and C is +C symmetric (C = C'). (A' denotes the transpose of the matrix A.) +C A is N-by-N, the right hand side C and the solution X are N-by-N, +C and scale is an output scale factor, set less than or equal to 1 +C to avoid overflow in X. The solution matrix X is overwritten +C onto C. +C +C A must be in Schur canonical form (as returned by LAPACK routines +C DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and +C 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its +C diagonal elements equal and its off-diagonal elements of opposite +C sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C upper quasi-triangular matrix A, in Schur canonical form. +C The part of A below the first sub-diagonal is not +C referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading N-by-N part of this array must +C contain the symmetric matrix C. +C On exit, if INFO >= 0, the leading N-by-N part of this +C array contains the symmetric solution matrix X. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if A and -A have common or very close eigenvalues; +C perturbed values were used to solve the equation +C (but the matrix A is unchanged). +C +C METHOD +C +C Bartels-Stewart algorithm is used. A set of equivalent linear +C algebraic systems of equations of order at most four are formed +C and solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine SB03AY by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, October 1982. +C Based on DTRLYP by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Continuous-time system, Lyapunov equation, matrix algebra, real +C Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TRANA + INTEGER INFO, LDA, LDC, N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ) +C .. +C .. Local Scalars .. + LOGICAL NOTRNA, LUPPER + INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, + $ MINK1N, MINK2N, MINL1N, MINL2N + DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SMIN, + $ SMLNUM, XNORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLANHS + EXTERNAL DDOT, DLAMCH, DLANHS, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, SB03MW, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + NOTRNA = LSAME( TRANA, 'N' ) + LUPPER = .TRUE. +C + INFO = 0 + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03MY', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( N*N ) / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, A, LDA, DUM ) ) +C + IF( NOTRNA ) THEN +C +C Solve A'*X + X*A = scale*C. +C +C The (K,L)th block of X is determined starting from +C upper-left corner column by column by +C +C A(K,K)'*X(K,L) + X(K,L)*A(L,L) = C(K,L) - R(K,L), +C +C where +C K-1 L-1 +C R(K,L) = SUM [A(I,K)'*X(I,L)] + SUM [X(K,J)*A(J,L)]. +C I=1 J=1 +C +C Start column loop (index = L). +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = 1 +C + DO 60 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 60 + L1 = L + L2 = L + IF( L.LT.N ) THEN + IF( A( L+1, L ).NE.ZERO ) + $ L2 = L2 + 1 + LNEXT = L2 + 1 + END IF +C +C Start row loop (index = K). +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = L +C + DO 50 K = L, N + IF( K.LT.KNEXT ) + $ GO TO 50 + K1 = K + K2 = K + IF( K.LT.N ) THEN + IF( A( K+1, K ).NE.ZERO ) + $ K2 = K2 + 1 + KNEXT = K2 + 1 + END IF +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 ) + A( L1, L1 ) + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 10 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + END IF +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), + $ LDA, ONE, ONE, VEC, 2, -A( L1, L1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 20 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 20 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L1, K2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) +C + VEC( 2, 1 ) = C( K1, L2 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( L1, L1 ), + $ LDA, ONE, ONE, VEC, 2, -A( K1, K1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) +C + VEC( 1, 2 ) = C( K1, L2 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) ) +C + VEC( 2, 2 ) = C( K2, L2 ) - + $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) + + $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L2 ), 1 ) ) +C + IF( K1.EQ.L1 ) THEN + CALL SB03MW( .FALSE., LUPPER, A( K1, K1 ), LDA, + $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) + IF( LUPPER ) THEN + X( 2, 1 ) = X( 1, 2 ) + ELSE + X( 1, 2 ) = X( 2, 1 ) + END IF + ELSE + CALL DLASY2( .TRUE., .FALSE., 1, 2, 2, A( K1, K1 ), + $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, + $ X, 2, XNORM, IERR ) + END IF + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 40 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 40 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 1, 2 ) + C( L1, K2 ) = X( 2, 1 ) + C( L2, K2 ) = X( 2, 2 ) + END IF + END IF +C + 50 CONTINUE +C + 60 CONTINUE +C + ELSE +C +C Solve A*X + X*A' = scale*C. +C +C The (K,L)th block of X is determined starting from +C bottom-right corner column by column by +C +C A(K,K)*X(K,L) + X(K,L)*A(L,L)' = C(K,L) - R(K,L), +C +C where +C N N +C R(K,L) = SUM [A(K,I)*X(I,L)] + SUM [X(K,J)*A(L,J)']. +C I=K+1 J=L+1 +C +C Start column loop (index = L). +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = N +C + DO 120 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 120 + L1 = L + L2 = L + IF( L.GT.1 ) THEN + IF( A( L, L-1 ).NE.ZERO ) + $ L1 = L1 - 1 + LNEXT = L1 - 1 + END IF + MINL1N = MIN( L1+1, N ) + MINL2N = MIN( L2+1, N ) +C +C Start row loop (index = K). +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = L +C + DO 110 K = L, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 110 + K1 = K + K2 = K + IF( K.GT.1 ) THEN + IF( A( K, K-1 ).NE.ZERO ) + $ K1 = K1 - 1 + KNEXT = K1 - 1 + END IF + MINK1N = MIN( K1+1, N ) + MINK2N = MIN( K2+1, N ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L1 ), 1 ) + + $ DDOT( N-L1, C( K1, MINL1N ), LDC, + $ A( L1, MINL1N ), LDA ) ) + SCALOC = ONE +C + A11 = A( K1, K1 ) + A( L1, L1 ) + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 70 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + END IF +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + + $ DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + + $ DDOT( N-L2, C( K2, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), + $ LDA, ONE, ONE, VEC, 2, -A( L1, L1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 80 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 80 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L1, K2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L1 ), 1 ) + + $ DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) ) +C + VEC( 2, 1 ) = C( K1, L2 ) - + $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L2 ), 1 ) + + $ DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( L1, L1 ), + $ LDA, ONE, ONE, VEC, 2, -A( K1, K1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 90 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 90 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + + $ DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) ) +C + VEC( 1, 2 ) = C( K1, L2 ) - + $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L2 ), 1 ) + + $ DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + + $ DDOT( N-L2, C( K2, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) ) +C + VEC( 2, 2 ) = C( K2, L2 ) - + $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L2 ), 1 ) + + $ DDOT( N-L2, C( K2, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) ) +C + IF( K1.EQ.L1 ) THEN + CALL SB03MW( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC, + $ 2, SCALOC, X, 2, XNORM, IERR ) + IF( LUPPER ) THEN + X( 2, 1 ) = X( 1, 2 ) + ELSE + X( 1, 2 ) = X( 2, 1 ) + END IF + ELSE + CALL DLASY2( .FALSE., .TRUE., 1, 2, 2, A( K1, K1 ), + $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, + $ X, 2, XNORM, IERR ) + END IF + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 100 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 1, 2 ) + C( L1, K2 ) = X( 2, 1 ) + C( L2, K2 ) = X( 2, 2 ) + END IF + END IF +C + 110 CONTINUE +C + 120 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB03MY *** + END diff --git a/modules/cacsd/src/slicot/sb03my.lo b/modules/cacsd/src/slicot/sb03my.lo new file mode 100755 index 000000000..10cdf8cd3 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03my.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03my.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03my.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03od.f b/modules/cacsd/src/slicot/sb03od.f new file mode 100755 index 000000000..a37beb70a --- /dev/null +++ b/modules/cacsd/src/slicot/sb03od.f @@ -0,0 +1,634 @@ + SUBROUTINE SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B, + $ LDB, SCALE, WR, WI, DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 upper triangular part of this +C array contains the Cholesky factor of the solution matrix +C X of the problem, X = op(U)'*op(U). +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 LDWORK = MAX(1,4*N + MIN(M,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 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. +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, SELECT1 + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2, LSAME, SELECT1 +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DGEQRF, DGERQF, + $ DLACPY, 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.MAX( 1, 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 + 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', SELECT1, 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 + 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 ) + 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 ) + 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 + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, MINMN*N ) + 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 +C Set the optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB03OD *** + END diff --git a/modules/cacsd/src/slicot/sb03od.lo b/modules/cacsd/src/slicot/sb03od.lo new file mode 100755 index 000000000..eb9a13402 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03od.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03od.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03od.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03or.f b/modules/cacsd/src/slicot/sb03or.f new file mode 100755 index 000000000..3c4640c5f --- /dev/null +++ b/modules/cacsd/src/slicot/sb03or.f @@ -0,0 +1,413 @@ + SUBROUTINE SB03OR( DISCR, LTRANS, N, M, S, LDS, A, LDA, C, LDC, + $ SCALE, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To compute the solution of the Sylvester equations +C +C op(S)'*X + X*op(A) = scale*C, if DISCR = .FALSE. or +C +C op(S)'*X*op(A) - X = scale*C, if DISCR = .TRUE. +C +C where op(K) = K or K' (i.e., the transpose of the matrix K), S is +C an N-by-N block upper triangular matrix with one-by-one and +C two-by-two blocks on the diagonal, A is an M-by-M matrix (M = 1 or +C M = 2), X and C are each N-by-M matrices, and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C The solution X is overwritten on C. +C +C SB03OR is a service routine for the Lyapunov solver SB03OT. +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the equation to be solved: +C = .FALSE.: op(S)'*X + X*op(A) = scale*C; +C = .TRUE. : op(S)'*X*op(A) - X = scale*C. +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix S and also the number of rows of +C matrices X and C. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A and also the number of columns +C of matrices X and C. M = 1 or M = 2. +C +C S (input) DOUBLE PRECISION array, dimension (LDS,N) +C The leading N-by-N upper Hessenberg part of the array S +C must contain the block upper triangular matrix. The +C elements below the upper Hessenberg part of the array S +C are not referenced. The array S must not contain +C diagonal blocks larger than two-by-two and the two-by-two +C blocks must only correspond to complex conjugate pairs of +C eigenvalues, not to real eigenvalues. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C A (input) DOUBLE PRECISION array, dimension (LDS,M) +C The leading M-by-M part of this array must contain a +C given matrix, where M = 1 or M = 2. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= M. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, C must contain an N-by-M matrix, where M = 1 or +C M = 2. +C On exit, C contains the N-by-M matrix X, the solution of +C the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if DISCR = .FALSE., and S and -A have common +C eigenvalues, or if DISCR = .TRUE., and S and A have +C eigenvalues whose product is equal to unity; +C a solution has been computed using slightly +C perturbed values. +C +C METHOD +C +C The LAPACK scheme for solving Sylvester equations is adapted. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0(N M) operations and is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routines SB03CW and SB03CX by +C Sven Hammarling, NAG Ltd, United Kingdom, Oct. 1986. +C Partly based on routine PLYAP4 by A. Varga, University of Bochum, +C May 1992. +C +C REVISIONS +C +C December 1997, April 1998, May 1999, April 2000. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, LDA, LDS, LDC, M, N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), S( LDS, * ) +C .. Local Scalars .. + LOGICAL TBYT + INTEGER DL, INFOM, ISGN, J, L, L1, L2, L2P1, LNEXT + DOUBLE PRECISION G11, G12, G21, G22, SCALOC, XNORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION AT( 2, 2 ), VEC( 2, 2 ), X( 2, 2 ) +C .. +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. +C .. External Subroutines .. + EXTERNAL DLASY2, DSCAL, SB04PX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( .NOT.( M.EQ.1 .OR. M.EQ.2 ) ) THEN + INFO = -4 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.M ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03OR', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + ISGN = 1 + TBYT = M.EQ.2 + INFOM = 0 +C +C Construct A'. +C + AT(1,1) = A(1,1) + IF ( TBYT ) THEN + AT(1,2) = A(2,1) + AT(2,1) = A(1,2) + AT(2,2) = A(2,2) + END IF +C + IF ( LTRANS ) THEN +C +C Start row loop (index = L). +C L1 (L2) : row index of the first (last) row of X(L). +C + LNEXT = N +C + DO 20 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 20 + L1 = L + L2 = L + IF( L.GT.1 ) THEN + IF( S( L, L-1 ).NE.ZERO ) + $ L1 = L1 - 1 + LNEXT = L1 - 1 + END IF + DL = L2 - L1 + 1 + L2P1 = MIN( L2+1, N ) +C + IF ( DISCR ) THEN +C +C Solve S*X*A' - X = scale*C. +C +C The L-th block of X is determined from +C +C S(L,L)*X(L)*A' - X(L) = C(L) - R(L), +C +C where +C +C N +C R(L) = SUM [S(L,J)*X(J)] * A' . +C J=L+1 +C + G11 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 1 ), 1 ) + IF ( TBYT ) THEN + G12 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 2 ), + $ 1 ) + VEC( 1, 1 ) = C( L1, 1 ) + G11*AT(1,1) + G12*AT(2,1) + VEC( 1, 2 ) = C( L1, 2 ) + G11*AT(1,2) + G12*AT(2,2) + ELSE + VEC (1, 1 ) = C( L1, 1 ) + G11*AT(1,1) + END IF + IF ( DL.NE.1 ) THEN + G21 = -DDOT( N-L2, S( L2, L2P1 ), LDS, C( L2P1, 1 ), + $ 1 ) + IF ( TBYT ) THEN + G22 = -DDOT( N-L2, S( L2, L2P1 ), LDS, + $ C( L2P1, 2 ), 1 ) + VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) + + $ G22*AT(2,1) + VEC( 2, 2 ) = C( L2, 2 ) + G21*AT(1,2) + + $ G22*AT(2,2) + ELSE + VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) + END IF + END IF + CALL SB04PX( .FALSE., .FALSE., -ISGN, DL, M, S( L1, L1 ), + $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, + $ INFO ) + ELSE +C +C Solve S*X + X*A' = scale*C. +C +C The L-th block of X is determined from +C +C S(L,L)*X(L) + X(L)*A' = C(L) - R(L), +C +C where +C N +C R(L) = SUM S(L,J)*X(J) . +C J=L+1 +C + VEC( 1, 1 ) = C( L1, 1 ) - + $ DDOT( N-L2, S( L1, L2P1 ), LDS, + $ C( L2P1, 1 ), 1 ) + IF ( TBYT ) + $ VEC( 1, 2 ) = C( L1, 2 ) - + $ DDOT( N-L2, S( L1, L2P1 ), LDS, + $ C( L2P1, 2 ), 1 ) +C + IF ( DL.NE.1 ) THEN + VEC( 2, 1 ) = C( L2, 1 ) - + $ DDOT( N-L2, S( L2, L2P1 ), LDS, + $ C( L2P1, 1 ), 1 ) + IF ( TBYT ) + $ VEC( 2, 2 ) = C( L2, 2 ) - + $ DDOT( N-L2, S( L2, L2P1 ), LDS, + $ C( L2P1, 2 ), 1 ) + END IF + CALL DLASY2( .FALSE., .FALSE., ISGN, DL, M, S( L1, L1 ), + $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, + $ INFO ) + END IF + INFOM = MAX( INFO, INFOM ) + IF ( SCALOC.NE.ONE ) THEN +C + DO 10 J = 1, M + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( L1, 1 ) = X( 1, 1 ) + IF ( TBYT ) C( L1, 2 ) = X( 1, 2 ) + IF ( DL.NE.1 ) THEN + C( L2, 1 ) = X( 2, 1 ) + IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) + END IF + 20 CONTINUE +C + ELSE +C +C Start row loop (index = L). +C L1 (L2) : row index of the first (last) row of X(L). +C + LNEXT = 1 +C + DO 40 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 40 + L1 = L + L2 = L + IF( L.LT.N ) THEN + IF( S( L+1, L ).NE.ZERO ) + $ L2 = L2 + 1 + LNEXT = L2 + 1 + END IF + DL = L2 - L1 + 1 +C + IF ( DISCR ) THEN +C +C Solve A'*X'*S - X' = scale*C'. +C +C The L-th block of X is determined from +C +C A'*X(L)'*S(L,L) - X(L)' = C(L)' - R(L), +C +C where +C +C L-1 +C R(L) = A' * SUM [X(J)'*S(J,L)] . +C J=1 +C + G11 = -DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) + IF ( TBYT ) THEN + G21 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 + AT(1,2)*G21 + VEC( 2, 1 ) = C( L1, 2 ) + AT(2,1)*G11 + AT(2,2)*G21 + ELSE + VEC (1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 + END IF + IF ( DL .NE. 1 ) THEN + G12 = -DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) + IF ( TBYT ) THEN + G22 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1 ) + VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 + + $ AT(1,2)*G22 + VEC( 2, 2 ) = C( L2, 2 ) + AT(2,1)*G12 + + $ AT(2,2)*G22 + ELSE + VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 + END IF + END IF + CALL SB04PX( .FALSE., .FALSE., -ISGN, M, DL, AT, 2, + $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, + $ XNORM, INFO ) + ELSE +C +C Solve A'*X' + X'*S = scale*C'. +C +C The L-th block of X is determined from +C +C A'*X(L)' + X(L)'*S(L,L) = C(L)' - R(L), +C +C where +C L-1 +C R(L) = SUM [X(J)'*S(J,L)]. +C J=1 +C + VEC( 1, 1 ) = C( L1, 1 ) - + $ DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) + IF ( TBYT ) + $ VEC( 2, 1 ) = C( L1, 2 ) - + $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1) +C + IF ( DL.NE.1 ) THEN + VEC( 1, 2 ) = C( L2, 1 ) - + $ DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) + IF ( TBYT ) + $ VEC( 2, 2 ) = C( L2, 2 ) - + $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1) + END IF + CALL DLASY2( .FALSE., .FALSE., ISGN, M, DL, AT, 2, + $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, + $ XNORM, INFO ) + END IF + INFOM = MAX( INFO, INFOM ) + IF ( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, M + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( L1, 1 ) = X( 1, 1 ) + IF ( TBYT ) C( L1, 2 ) = X( 2, 1 ) + IF ( DL.NE.1 ) THEN + C( L2, 1 ) = X( 1, 2 ) + IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) + END IF + 40 CONTINUE + END IF +C + INFO = INFOM + RETURN +C *** Last line of SB03OR *** + END diff --git a/modules/cacsd/src/slicot/sb03or.lo b/modules/cacsd/src/slicot/sb03or.lo new file mode 100755 index 000000000..4ab53fd41 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03or.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03or.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03or.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03ot.f b/modules/cacsd/src/slicot/sb03ot.f new file mode 100755 index 000000000..6f0a7c09f --- /dev/null +++ b/modules/cacsd/src/slicot/sb03ot.f @@ -0,0 +1,967 @@ + SUBROUTINE SB03OT( DISCR, LTRANS, N, S, LDS, R, LDR, SCALE, DWORK, + $ INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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. +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(2), 2 ) + CALL DCOPY( KSIZE, DWORK(K2), 1, DWORK(1), 2 ) + CALL MB04OD( 'Full', KSIZE, 0, 2, R(K+2,K+2), LDR, + $ DWORK, 2, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K3) ) + END IF + ELSE +C +C 1-by-1 block. +C +C Make sure S is stable or convergent and find u11 in +C equation (5.13) or (10.15). +C + IF ( DISCR ) THEN + ABSSKK = ABS( S(K,K) ) + IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) + ELSE + IF ( S(K,K).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ABS( TWO*S(K,K) ) ) + END IF +C + SCALOC = ONE + IF( TEMP.LT.SMIN ) THEN + TEMP = SMIN + INFOM = 1 + END IF + DR = ABS( R(K,K) ) + IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN + IF( DR.GT.BIGNUM*TEMP ) + $ SCALOC = ONE / DR + END IF + ALPHA = SIGN( TEMP, R(K,K) ) + R(K,K) = R(K,K)/ALPHA + IF( SCALOC.NE.ONE ) THEN +C + DO 60 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 60 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C If we are not at the end of S then set up and solve +C equation (5.14) or (10.16). ksize is the order of the +C remainder of S. k1 and k2 point to the start of vectors +C in DWORK. +C + IF ( KOUNT.LE.N ) THEN + KSIZE = N - K + K1 = KSIZE + 1 + K2 = KSIZE + K1 +C +C Form the right-hand side in DWORK( 1 ),..., +C DWORK( n - k ). +C + CALL DCOPY( KSIZE, R(K,K+1), LDR, DWORK, 1 ) + CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(K,K+1), LDS, DWORK, + $ 1 ) + ELSE + CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(K,K+1), LDS, + $ DWORK, 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution is +C overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S(K+1,K+1), LDS, + $ S(K,K), 1, DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 70 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 70 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next ( n - k ) elements +C of DWORK, copy the solution back into R and copy +C the row of R back into DWORK. +C + CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) + CALL DSWAP( KSIZE, DWORK, 1, R(K,K+1), LDR ) +C +C Now form the matrix Rhat of equation (5.15) or +C (10.17), first computing y in DWORK, and then +C updating R1. +C + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) + ELSE +C +C First form lambda( 1 )*r and then add in +C alpha*u11*s. +C + CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) + CALL DAXPY( KSIZE, ALPHA*R(K,K), S(K,K+1), LDS, + $ DWORK, 1 ) +C +C Now form alpha*S1'*u, first multiplying by the +C sub-diagonal of S1 and then the triangular part +C of S1, and add the result in DWORK. +C + J1 = K + 1 +C + DO 80 J = 1, KSIZE-1 + IF ( S(J1+1,J1).NE.ZERO ) DWORK(J) + $ = ALPHA*S(J1+1,J1)*DWORK(K1+J) + DWORK(J) + J1 = J1 + 1 + 80 CONTINUE +C + CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', + $ KSIZE, S(K+1,K+1), LDS, DWORK(K1), 1 ) + CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) + END IF + CALL MB04OD( 'Full', KSIZE, 0, 1, R(K+1,K+1), LDR, + $ DWORK, 1, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K1) ) + END IF + END IF + GO TO 10 + END IF +C END WHILE 10 +C + ELSE +C +C Case op(M) = M'. +C + KOUNT = N +C + 90 CONTINUE +C WHILE( KOUNT.GE.1 )LOOP + IF ( KOUNT.GE.1 ) THEN + K = KOUNT + IF ( KOUNT.EQ.1 ) THEN + TBYT = .FALSE. + KOUNT = KOUNT - 1 + ELSE IF ( S(K,K-1).EQ.ZERO ) THEN + TBYT = .FALSE. + KOUNT = KOUNT - 1 + ELSE + TBYT = .TRUE. + K = K - 1 + IF ( K.GT.1 ) THEN + IF ( S(K,K-1).NE.ZERO ) THEN + INFO = 3 + RETURN + END IF + END IF + KOUNT = KOUNT - 2 + END IF + IF ( TBYT ) THEN +C +C Solve the two-by-two Lyapunov equation corresponding to +C (6.1) or (10.19), using the routine SB03OY. +C + B(1,1) = S(K,K) + B(2,1) = S(K+1,K) + B(1,2) = S(K,K+1) + B(2,2) = S(K+1,K+1) + U(1,1) = R(K,K) + U(1,2) = R(K,K+1) + U(2,2) = R(K+1,K+1) +C + CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, + $ SCALOC, INFO ) + IF ( INFO.GT.1 ) + $ RETURN + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 100 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 100 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + R(K,K) = U(1,1) + R(K,K+1) = U(1,2) + R(K+1,K+1) = U(2,2) +C +C If we are not at the front of S then set up and solve +C equation corresponding to (6.2) or (10.20). +C +C Note that SB03OY returns ( inv( u11 )*s11*u11 ) in B +C and returns scaled alpha, alpha = inv( u11 )*r11, in A. +C ksize is the order of the remainder leading part of S. +C k1, k2 and k3 point to the start of vectors in DWORK. +C + IF ( KOUNT.GE.1 ) THEN + KSIZE = K - 1 + K1 = KSIZE + 1 + K2 = KSIZE + K1 + K3 = KSIZE + K2 +C +C Form the right-hand side of equations corresponding to +C (6.2) or (10.20), the first column in DWORK( 1 ) ,..., +C DWORK( k - 1 ) the second in DWORK( k ) ,..., +C DWORK( 2*( k - 1 ) ). +C + CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) + CALL DCOPY( KSIZE, R(1,K+1), 1, DWORK(K1), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', + $ KSIZE, 2, -ONE, A, 2, DWORK, KSIZE ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) + CALL DAXPY( KSIZE, -R(K,K+1), S(1,K), 1, DWORK(K1), + $ 1) + CALL DAXPY( KSIZE, -R(K+1,K+1), S(1,K+1), 1, + $ DWORK(K1), 1 ) + ELSE + CALL DAXPY( KSIZE, -( R(K,K)*B(1,1) + R(K,K+1) + $ *B(1,2) ), S(1,K), 1, DWORK, 1 ) + CALL DAXPY( KSIZE, -R(K+1,K+1)*B(1,2), S(1,K+1), 1, + $ DWORK, 1 ) + CALL DAXPY( KSIZE, -( R(K,K)*B(2,1) + R(K,K+1) + $ *B(2,2) ), S(1,K), 1, DWORK(K1), 1 ) + CALL DAXPY( KSIZE, -R(K+1,K+1)*B(2,2), S(1,K+1), 1, + $ DWORK(K1), 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution +C is overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S, LDS, B, 2, + $ DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 110 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 110 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next 2*( k - 1 ) elements +C of DWORK. +C + CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) +C +C Now form the matrix Rhat of equation corresponding +C to (6.4) or (10.22) (corrected version). +C + IF ( CONT ) THEN +C +C Swap the two columns of R with DWORK. +C + CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) + CALL DSWAP( KSIZE, DWORK(K1), 1, R(1,K+1), 1 ) +C +C 1st column: +C + CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, + $ 1 ) +C +C 2nd column: +C + CALL DAXPY( KSIZE, -A(1,2), DWORK(K2), 1, + $ DWORK(K1), 1 ) + CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, + $ DWORK(K1), 1 ) + ELSE +C +C Form v = S1*u + s*u11, overwriting v on DWORK. +C +C Compute S1*u, first multiplying by the triangular +C part of S1. +C + CALL DTRMM( 'Left', 'Upper', 'No transpose', + $ 'Non-unit', KSIZE, 2, ONE, S, LDS, + $ DWORK, KSIZE ) +C +C Then multiply by the subdiagonal of S1 and add in +C to the above result. +C + J1 = K1 +C + DO 120 J = 2, KSIZE + J1 = J1 + 1 + IF ( S(J,J-1).NE.ZERO ) THEN + DWORK(J) = S(J,J-1)*DWORK(K2+J-2) + DWORK(J) + DWORK(J1) = S(J,J-1)*DWORK(K3+J-2) + + $ DWORK(J1) + END IF + 120 CONTINUE +C +C Add in s*u11. +C + CALL DAXPY( KSIZE, R(K,K), S(1,K), 1, DWORK, 1 ) + CALL DAXPY( KSIZE, R(K,K+1), S(1,K), 1, DWORK(K1), + $ 1 ) + CALL DAXPY( KSIZE, R(K+1,K+1), S(1,K+1), 1, + $ DWORK(K1), 1 ) +C +C Next recover r from R, swapping r with u. +C + CALL DSWAP( KSIZE, DWORK(K2), 1, R(1,K), 1 ) + CALL DSWAP( KSIZE, DWORK(K3), 1, R(1,K+1), 1 ) +C +C Now we perform the QL factorization. +C +C ( a' ) = Q*( t ), +C ( b' ) +C +C and form +C +C ( p' ) = Q'*( r' ). +C ( y' ) ( v' ) +C +C y is then the correct vector to use in the +C relation corresponding to (10.22). +C Note that a is upper triangular and that t and +C p are not required. +C + CALL DLARFG( 3, A(2,2), B(2,1), 2, TAU1 ) + V1 = B(2,1) + T1 = TAU1*V1 + V2 = B(2,2) + T2 = TAU1*V2 + SUM = A(1,2) + V1*B(1,1) + V2*B(1,2) + B(1,1) = B(1,1) - SUM*T1 + B(1,2) = B(1,2) - SUM*T2 + CALL DLARFG( 3, A(1,1), B(1,1), 2, TAU2 ) + V3 = B(1,1) + T3 = TAU2*V3 + V4 = B(1,2) + T4 = TAU2*V4 + J1 = K1 + J2 = K2 + J3 = K3 +C + DO 130 J = 1, KSIZE + SUM = DWORK(J3) + V1*DWORK(J) + V2*DWORK(J1) + D1 = DWORK(J) - SUM*T1 + D2 = DWORK(J1) - SUM*T2 + SUM = DWORK(J2) + V3*D1 + V4*D2 + DWORK(J) = D1 - SUM*T3 + DWORK(J1) = D2 - SUM*T4 + J1 = J1 + 1 + J2 = J2 + 1 + J3 = J3 + 1 + 130 CONTINUE +C + END IF +C +C Now update R1 to give Rhat. +C + CALL MB04ND( 'Full', KSIZE, 0, 2, R, LDR, DWORK, + $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K3) ) + END IF + ELSE +C +C 1-by-1 block. +C +C Make sure S is stable or convergent and find u11 in +C equation corresponding to (5.13) or (10.15). +C + IF ( DISCR ) THEN + ABSSKK = ABS( S(K,K) ) + IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) + ELSE + IF ( S(K,K).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ABS( TWO*S(K,K) ) ) + END IF +C + SCALOC = ONE + IF( TEMP.LT.SMIN ) THEN + TEMP = SMIN + INFOM = 1 + END IF + DR = ABS( R(K,K) ) + IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN + IF( DR.GT.BIGNUM*TEMP ) + $ SCALOC = ONE / DR + END IF + ALPHA = SIGN( TEMP, R(K,K) ) + R(K,K) = R(K,K)/ALPHA + IF( SCALOC.NE.ONE ) THEN +C + DO 140 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 140 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C If we are not at the front of S then set up and solve +C equation corresponding to (5.14) or (10.16). ksize is +C the order of the remainder leading part of S. k1 and k2 +C point to the start of vectors in DWORK. +C + IF ( KOUNT.GE.1 ) THEN + KSIZE = K - 1 + K1 = KSIZE + 1 + K2 = KSIZE + K1 +C +C Form the right-hand side in DWORK( 1 ),..., +C DWORK( k - 1 ). +C + CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) + CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) + ELSE + CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(1,K), 1, + $ DWORK, 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution is +C overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S, LDS, S(K,K), + $ 1, DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 150 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 150 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next ( k - 1 ) elements +C of DWORK, copy the solution back into R and copy +C the column of R back into DWORK. +C + CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) + CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) +C +C Now form the matrix Rhat of equation corresponding +C to (5.15) or (10.17), first computing y in DWORK, +C and then updating R1. +C + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) + ELSE +C +C First form lambda( 1 )*r and then add in +C alpha*u11*s. +C + CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) + CALL DAXPY( KSIZE, ALPHA*R(K,K), S(1,K), 1, DWORK, + $ 1 ) +C +C Now form alpha*S1*u, first multiplying by the +C sub-diagonal of S1 and then the triangular part +C of S1, and add the result in DWORK. +C + DO 160 J = 2, KSIZE + IF ( S(J,J-1).NE.ZERO ) DWORK(J) + $ = ALPHA*S(J,J-1)*DWORK(K1+J-2) + DWORK(J) + 160 CONTINUE +C + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', + $ KSIZE, S, LDS, DWORK(K1), 1 ) + CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) + END IF + CALL MB04ND( 'Full', KSIZE, 0, 1, R, LDR, DWORK, + $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K1) ) + END IF + END IF + GO TO 90 + END IF +C END WHILE 90 +C + END IF + INFO = INFOM + RETURN +C *** Last line of SB03OT *** + END diff --git a/modules/cacsd/src/slicot/sb03ot.lo b/modules/cacsd/src/slicot/sb03ot.lo new file mode 100755 index 000000000..59143ce1e --- /dev/null +++ b/modules/cacsd/src/slicot/sb03ot.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03ot.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03ot.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03ou.f b/modules/cacsd/src/slicot/sb03ou.f new file mode 100755 index 000000000..3863ac87d --- /dev/null +++ b/modules/cacsd/src/slicot/sb03ou.f @@ -0,0 +1,394 @@ + SUBROUTINE SB03OU( DISCR, LTRANS, N, M, A, LDA, B, LDB, TAU, U, + $ LDU, SCALE, DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve for X = op(U)'*op(U) either the stable non-negative +C definite continuous-time Lyapunov equation +C 2 +C op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) +C +C or the convergent non-negative definite discrete-time Lyapunov +C equation +C 2 +C op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) +C +C where op(K) = K or K' (i.e., the transpose of the matrix K), A is +C an N-by-N matrix in real Schur form, op(B) is an M-by-N matrix, +C U is an upper triangular matrix containing the Cholesky factor of +C the solution matrix X, X = op(U)'*op(U), and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C If matrix B has full rank then the solution matrix X will be +C positive-definite and hence the Cholesky factor U will be +C nonsingular, but if B is rank deficient then X may only be +C positive semi-definite and U will be singular. +C +C In the case of equation (1) the matrix A must be stable (that +C is, all the eigenvalues of A must have negative real parts), +C and for equation (2) the matrix A must be convergent (that is, +C all the eigenvalues of A must lie inside the unit circle). +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the type of Lyapunov equation to be solved as +C follows: +C = .TRUE. : Equation (2), discrete-time case; +C = .FALSE.: Equation (1), continuous-time case. +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and the number of columns in +C matrix op(B). N >= 0. +C +C M (input) INTEGER +C The number of rows in matrix op(B). M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain a real Schur form matrix S. The elements +C below the upper Hessenberg part of the array A are not +C referenced. The 2-by-2 blocks must only correspond to +C complex conjugate pairs of eigenvalues (not to real +C eigenvalues). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C if LTRANS = .FALSE., and dimension (LDB,M), if +C LTRANS = .TRUE.. +C On entry, if LTRANS = .FALSE., the leading M-by-N part of +C this array must contain the coefficient matrix B of the +C equation. +C On entry, if LTRANS = .TRUE., the leading N-by-M part of +C this array must contain the coefficient matrix B of the +C equation. +C On exit, if LTRANS = .FALSE., the leading +C MIN(M,N)-by-MIN(M,N) upper triangular part of this array +C contains the upper triangular matrix R (as defined in +C METHOD), and the M-by-MIN(M,N) strictly lower triangular +C part together with the elements of the array TAU are +C overwritten by details of the matrix P (also defined in +C METHOD). When M < N, columns (M+1),...,N of the array B +C are overwritten by the matrix Z (see METHOD). +C On exit, if LTRANS = .TRUE., the leading +C MIN(M,N)-by-MIN(M,N) upper triangular part of +C B(1:N,M-N+1), if M >= N, or of B(N-M+1:N,1:M), if M < N, +C contains the upper triangular matrix R (as defined in +C METHOD), and the remaining elements (below the diagonal +C of R) together with the elements of the array TAU are +C overwritten by details of the matrix P (also defined in +C METHOD). When M < N, rows 1,...,(N-M) of the array B +C are overwritten by the matrix Z (see METHOD). +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,M), if LTRANS = .FALSE., +C LDB >= MAX(1,N), if LTRANS = .TRUE.. +C +C TAU (output) DOUBLE PRECISION array of dimension (MIN(N,M)) +C This array contains the scalar factors of the elementary +C reflectors defining the matrix P. +C +C U (output) DOUBLE PRECISION array of dimension (LDU,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor of the solution matrix X of +C the problem, X = op(U)'*op(U). +C The array U may be identified with B in the calling +C statement, if B is properly dimensioned, and the +C intermediate results returned in B are not needed. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,4*N). +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the Lyapunov equation is (nearly) singular +C (warning indicator); +C if DISCR = .FALSE., this means that while the matrix +C A has computed eigenvalues with negative real parts, +C it is only just stable in the sense that small +C perturbations in A can make one or more of the +C eigenvalues have a non-negative real part; +C if DISCR = .TRUE., this means that while the matrix +C A has computed eigenvalues inside the unit circle, +C it is nevertheless only just convergent, in the +C sense that small perturbations in A can make one or +C more of the eigenvalues lie outside the unit circle; +C perturbed values were used to solve the equation +C (but the matrix A is unchanged); +C = 2: if matrix A is not stable (that is, one or more of +C the eigenvalues of A has a non-negative real part), +C if DISCR = .FALSE., or not convergent (that is, one +C or more of the eigenvalues of A lies outside the +C unit circle), if DISCR = .TRUE.; +C = 3: if matrix A has two or more consecutive non-zero +C elements on the first sub-diagonal, so that there is +C a block larger than 2-by-2 on the diagonal; +C = 4: if matrix A has a 2-by-2 diagonal block with real +C eigenvalues instead of a complex conjugate pair. +C +C METHOD +C +C The method used by the routine is based on the Bartels and +C Stewart method [1], except that it finds the upper triangular +C matrix U directly without first finding X and without the need +C to form the normal matrix op(B)'*op(B) [2]. +C +C If LTRANS = .FALSE., the matrix B is factored as +C +C B = P ( R ), M >= N, B = P ( R Z ), M < N, +C ( 0 ) +C +C (QR factorization), where P is an M-by-M orthogonal matrix and +C R is a square upper triangular matrix. +C +C If LTRANS = .TRUE., the matrix B is factored as +C +C B = ( 0 R ) P, M >= N, B = ( Z ) P, M < N, +C ( R ) +C +C (RQ factorization), where P is an M-by-M orthogonal matrix and +C R is a square upper triangular matrix. +C +C These factorizations are used to solve the continuous-time +C Lyapunov equation in the canonical form +C 2 +C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), +C +C or the discrete-time Lyapunov equation in the canonical form +C 2 +C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F), +C +C where U and F are N-by-N upper triangular matrices, and +C +C F = R, if M >= N, or +C +C F = ( R ), if LTRANS = .FALSE., or +C ( 0 ) +C +C F = ( 0 Z ), if LTRANS = .TRUE., if M < N. +C ( 0 R ) +C +C The canonical equation is solved for U. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. +C Solution of the matrix equation A'X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if A is only just stable (or convergent) then the Lyapunov +C equation will be ill-conditioned. "Large" elements in U relative +C to those of A and B, or a "small" value for scale, are symptoms +C of ill-conditioning. A condition estimate can be computed using +C SLICOT Library routine SB03MD. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, +C NAG Ltd, United Kingdom. +C Partly based on routine PLYAPS by A. Varga, University of Bochum, +C May 1992. +C +C REVISIONS +C +C Dec. 1997, April 1998, May 1999. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, LDA, LDB, LDU, LDWORK, M, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), U(LDU,*) +C .. Local Scalars .. + INTEGER I, J, K, L, MN, WRKOPT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEQRF, DGERQF, DLACPY, DLASET, SB03OT, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( ( LDB.LT.MAX( 1, M ) .AND. .NOT.LTRANS ) .OR. + $ ( LDB.LT.MAX( 1, N ) .AND. LTRANS ) ) THEN + INFO = -8 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03OU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + MN = MIN( N, M ) + IF ( MN.EQ.0 ) THEN + SCALE = ONE + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( LTRANS ) THEN +C +C Case op(K) = K'. +C +C Perform the RQ factorization of B. +C Workspace: need N; +C prefer N*NB. +C + CALL DGERQF( N, M, B, LDB, TAU, DWORK, LDWORK, INFO ) +C +C The triangular matrix F is constructed in the array U so that +C U can share the same memory as B. +C + IF ( M.GE.N ) THEN + CALL DLACPY( 'Upper', MN, N, B(1,M-N+1), LDB, U, LDU ) + ELSE +C + DO 10 I = M, 1, -1 + CALL DCOPY( N-M+I, B(1,I), 1, U(1,N-M+I), 1 ) + 10 CONTINUE +C + CALL DLASET( 'Full', N, N-M, ZERO, ZERO, U, LDU ) + END IF + ELSE +C +C Case op(K) = K. +C +C Perform the QR factorization of B. +C Workspace: need N; +C prefer N*NB. +C + CALL DGEQRF( M, N, B, LDB, TAU, DWORK, LDWORK, INFO ) + CALL DLACPY( 'Upper', MN, N, B, LDB, U, LDU ) + IF ( M.LT.N ) + $ CALL DLASET( 'Upper', N-M, N-M, ZERO, ZERO, U(M+1,M+1), + $ LDU ) + END IF + WRKOPT = DWORK(1) +C +C Solve the canonical Lyapunov equation +C 2 +C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), +C +C or +C 2 +C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F) +C +C for U. +C + CALL SB03OT( DISCR, LTRANS, N, A, LDA, U, LDU, SCALE, DWORK, + $ INFO ) + IF ( INFO.NE.0 .AND. INFO.NE.1 ) + $ RETURN +C +C Make the diagonal elements of U non-negative. +C + IF ( LTRANS ) THEN +C + DO 30 J = 1, N + IF ( U(J,J).LT.ZERO ) THEN +C + DO 20 I = 1, J + U(I,J) = -U(I,J) + 20 CONTINUE +C + END IF + 30 CONTINUE +C + ELSE + K = 1 +C + DO 50 J = 1, N + DWORK(K) = U(J,J) + L = 1 +C + DO 40 I = 1, J + IF ( DWORK(L).LT.ZERO ) U(I,J) = -U(I,J) + L = L + 1 + 40 CONTINUE +C + K = K + 1 + 50 CONTINUE +C + END IF +C + DWORK(1) = MAX( WRKOPT, 4*N ) + RETURN +C *** Last line of SB03OU *** + END diff --git a/modules/cacsd/src/slicot/sb03ou.lo b/modules/cacsd/src/slicot/sb03ou.lo new file mode 100755 index 000000000..ff529ea9c --- /dev/null +++ b/modules/cacsd/src/slicot/sb03ou.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03ou.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03ou.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03ov.f b/modules/cacsd/src/slicot/sb03ov.f new file mode 100755 index 000000000..3d41014f9 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03ov.f @@ -0,0 +1,89 @@ + SUBROUTINE SB03OV( A, B, C, S ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To construct a complex plane rotation such that, for a complex +C number a and a real number b, +C +C ( conjg( c ) s )*( a ) = ( d ), +C ( -s c ) ( b ) ( 0 ) +C +C where d is always real and is overwritten on a, so that on +C return the imaginary part of a is zero. b is unaltered. +C +C This routine has A and C declared as REAL, because it is intended +C for use within a real Lyapunov solver and the REAL declarations +C mean that a standard Fortran DOUBLE PRECISION version may be +C readily constructed. However A and C could safely be declared +C COMPLEX in the calling program, although some systems may give a +C type mismatch warning. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C A (input/output) DOUBLE PRECISION array, dimension (2) +C On entry, A(1) and A(2) must contain the real and +C imaginary part, respectively, of the complex number a. +C On exit, A(1) contains the real part of d, and A(2) is +C set to zero. +C +C B (input) DOUBLE PRECISION +C The real number b. +C +C C (output) DOUBLE PRECISION array, dimension (2) +C C(1) and C(2) contain the real and imaginary part, +C respectively, of the complex number c, the cosines of +C the plane rotation. +C +C S (output) DOUBLE PRECISION +C The real number s, the sines of the plane rotation. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB03CV by Sven Hammarling, +C NAG Ltd., United Kingdom, May 1985. +C +C REVISIONS +C +C Dec. 1997. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation. +C +C ***************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION B, S +C .. Array Arguments .. + DOUBLE PRECISION A(2), C(2) +C .. Local Scalars .. + DOUBLE PRECISION D +C .. External Functions .. + DOUBLE PRECISION DLAPY3 + EXTERNAL DLAPY3 +C .. Executable Statements .. +C + D = DLAPY3( A(1), A(2), B ) + IF ( D.EQ.ZERO ) THEN + C(1) = ONE + C(2) = ZERO + S = ZERO + ELSE + C(1) = A(1)/D + C(2) = A(2)/D + S = B/D + A(1) = D + A(2) = ZERO + END IF +C + RETURN +C *** Last line of SB03OV *** + END diff --git a/modules/cacsd/src/slicot/sb03ov.lo b/modules/cacsd/src/slicot/sb03ov.lo new file mode 100755 index 000000000..5bd6710e9 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03ov.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03ov.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03ov.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03oy.f b/modules/cacsd/src/slicot/sb03oy.f new file mode 100755 index 000000000..5d4d37126 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03oy.f @@ -0,0 +1,677 @@ + SUBROUTINE SB03OY( DISCR, LTRANS, ISGN, S, LDS, R, LDR, A, LDA, + $ SCALE, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve for the Cholesky factor U of X, +C +C op(U)'*op(U) = X, +C +C where U is a two-by-two upper triangular matrix, either the +C continuous-time two-by-two Lyapunov equation +C 2 +C op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R), +C +C when DISCR = .FALSE., or the discrete-time two-by-two Lyapunov +C equation +C 2 +C op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R), +C +C when DISCR = .TRUE., where op(K) = K or K' (i.e., the transpose of +C the matrix K), S is a two-by-two matrix with complex conjugate +C eigenvalues, R is a two-by-two upper triangular matrix, +C ISGN = -1 or 1, and scale is an output scale factor, set less +C than or equal to 1 to avoid overflow in X. The routine also +C computes two matrices, B and A, so that +C 2 +C B*U = U*S and A*U = scale *R, if LTRANS = .FALSE., or +C 2 +C U*B = S*U and U*A = scale *R, if LTRANS = .TRUE., +C which are used by the general Lyapunov solver. +C In the continuous-time case ISGN*S must be stable, so that its +C eigenvalues must have strictly negative real parts. +C In the discrete-time case S must be convergent if ISGN = 1, that +C is, its eigenvalues must have moduli less than unity, or S must +C be completely divergent if ISGN = -1, that is, its eigenvalues +C must have moduli greater than unity. +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the equation to be solved: 2 +C = .FALSE.: op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R); +C 2 +C = .TRUE. : op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R). +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C S (input/output) DOUBLE PRECISION array, dimension (LDS,2) +C On entry, S must contain a 2-by-2 matrix. +C On exit, S contains a 2-by-2 matrix B such that B*U = U*S, +C if LTRANS = .FALSE., or U*B = S*U, if LTRANS = .TRUE.. +C Notice that if U is nonsingular then +C B = U*S*inv( U ), if LTRANS = .FALSE. +C B = inv( U )*S*U, if LTRANS = .TRUE.. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= 2. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,2) +C On entry, R must contain a 2-by-2 upper triangular matrix. +C The element R( 2, 1 ) is not referenced. +C On exit, R contains U, the 2-by-2 upper triangular +C Cholesky factor of the solution X, X = op(U)'*op(U). +C +C LDR INTEGER +C The leading dimension of array R. LDR >= 2. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,2) +C A contains a 2-by-2 upper triangular matrix A satisfying +C A*U/scale = scale*R, if LTRANS = .FALSE., or +C U*A/scale = scale*R, if LTRANS = .TRUE.. +C Notice that if U is nonsingular then +C A = scale*scale*R*inv( U ), if LTRANS = .FALSE. +C A = scale*scale*inv( U )*R, if LTRANS = .TRUE.. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= 2. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Lyapunov equation is (nearly) singular +C (warning indicator); +C if DISCR = .FALSE., this means that while the +C matrix S has computed eigenvalues with negative real +C parts, it is only just stable in the sense that +C small perturbations in S can make one or more of the +C eigenvalues have a non-negative real part; +C if DISCR = .TRUE., this means that while the +C matrix S has computed eigenvalues inside the unit +C circle, it is nevertheless only just convergent, in +C the sense that small perturbations in S can make one +C or more of the eigenvalues lie outside the unit +C circle; +C perturbed values were used to solve the equation +C (but the matrix S is unchanged); +C = 2: if DISCR = .FALSE., and ISGN*S is not stable or +C if DISCR = .TRUE., ISGN = 1 and S is not convergent +C or if DISCR = .TRUE., ISGN = -1 and S is not +C completely divergent; +C = 4: if S has real eigenvalues. +C +C NOTE: In the interests of speed, this routine does not check all +C inputs for errors. +C +C METHOD +C +C The LAPACK scheme for solving 2-by-2 Sylvester equations is +C adapted for 2-by-2 Lyapunov equations, but directly computing the +C Cholesky factor of the solution. +C +C REFERENCES +C +C [1] Hammarling S. J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB03CY by Sven Hammarling, +C NAG Ltd., United Kingdom, November 1986. +C Partly based on SB03CY and PLYAP2 by A. Varga, University of +C Bochum, May 1992. +C +C REVISIONS +C +C Dec. 1997, April 1998. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ***************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ FOUR = 4.0D0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, ISGN, LDA, LDR, LDS + DOUBLE PRECISION SCALE +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + DOUBLE PRECISION ABSB, ABSG, ABST, ALPHA, BIGNUM, E1, E2, EPS, + $ ETA, P1, P3, P3I, P3R, S11, S12, S21, S22, + $ SCALOC, SGN, SMIN, SMLNUM, SNP, SNQ, SNT, TEMPI, + $ TEMPR, V1, V3 +C .. Local Arrays .. + DOUBLE PRECISION CSP(2), CSQ(2), CST(2), DELTA(2), DP(2), DT(2), + $ G(2), GAMMA(2), P2(2), T(2), TEMP(2), V2(2), + $ X11(2), X12(2), X21(2), X22(2), Y(2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DLAPY3 + EXTERNAL DLAMCH, DLAPY2, DLAPY3 +C .. External Subroutines .. + EXTERNAL DLABAD, DLANV2, SB03OV +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +C .. Executable Statements .. +C +C The comments in this routine refer to notation and equation +C numbers in sections 6 and 10 of [1]. +C +C Find the eigenvalue lambda = E1 - i*E2 of s11. +C + INFO = 0 + SGN = ISGN + S11 = S(1,1) + S12 = S(1,2) + S21 = S(2,1) + S22 = S(2,2) +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*FOUR / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*MAX( ABS( S11 ), ABS( S12 ), + $ ABS( S21 ), ABS( S22 ) ) ) + SCALE = ONE +C + CALL DLANV2( S11, S12, S21, S22, TEMPR, TEMPI, E1, E2, CSP, CSQ ) + IF ( TEMPI.EQ.ZERO ) THEN + INFO = 4 + RETURN + END IF + ABSB = DLAPY2( E1, E2 ) + IF ( DISCR ) THEN + IF ( SGN*( ABSB - ONE ).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + ELSE + IF ( SGN*E1.GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Compute the cos and sine that define Qhat. The sine is real. +C + TEMP(1) = S(1,1) - E1 + TEMP(2) = E2 + IF ( LTRANS ) TEMP(2) = -E2 + CALL SB03OV( TEMP, S(2,1), CSQ, SNQ ) +C +C beta in (6.9) is given by beta = E1 + i*E2, compute t. +C + TEMP(1) = CSQ(1)*S(1,2) - SNQ*S(1,1) + TEMP(2) = CSQ(2)*S(1,2) + TEMPR = CSQ(1)*S(2,2) - SNQ*S(2,1) + TEMPI = CSQ(2)*S(2,2) + T(1) = CSQ(1)*TEMP(1) - CSQ(2)*TEMP(2) + SNQ*TEMPR + T(2) = CSQ(1)*TEMP(2) + CSQ(2)*TEMP(1) + SNQ*TEMPI +C + IF ( LTRANS ) THEN +C ( -- ) +C Case op(M) = M'. Note that the modified R is ( p3 p2 ). +C ( 0 p1 ) +C +C Compute the cos and sine that define Phat. +C + TEMP(1) = CSQ(1)*R(2,2) - SNQ*R(1,2) + TEMP(2) = -CSQ(2)*R(2,2) + CALL SB03OV( TEMP, -SNQ*R(1,1), CSP, SNP ) +C +C Compute p1, p2 and p3 of the relation corresponding to (6.11). +C + P1 = TEMP(1) + TEMP(1) = CSQ(1)*R(1,2) + SNQ*R(2,2) + TEMP(2) = -CSQ(2)*R(1,2) + TEMPR = CSQ(1)*R(1,1) + TEMPI = -CSQ(2)*R(1,1) + P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR + P2(2) = -CSP(1)*TEMP(2) - CSP(2)*TEMP(1) - SNP*TEMPI + P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) + P3I = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*TEMP(2) + ELSE +C +C Case op(M) = M. +C +C Compute the cos and sine that define Phat. +C + TEMP(1) = CSQ(1)*R(1,1) + SNQ*R(1,2) + TEMP(2) = CSQ(2)*R(1,1) + CALL SB03OV( TEMP, SNQ*R(2,2), CSP, SNP ) +C +C Compute p1, p2 and p3 of (6.11). +C + P1 = TEMP(1) + TEMP(1) = CSQ(1)*R(1,2) - SNQ*R(1,1) + TEMP(2) = CSQ(2)*R(1,2) + TEMPR = CSQ(1)*R(2,2) + TEMPI = CSQ(2)*R(2,2) + P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR + P2(2) = CSP(1)*TEMP(2) + CSP(2)*TEMP(1) + SNP*TEMPI + P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) + P3I = CSP(2)*TEMPR - CSP(1)*TEMPI + SNP*TEMP(2) + END IF +C +C Make p3 real by multiplying by conjg ( p3 )/abs( p3 ) to give +C +C p3 := abs( p3 ). +C + IF ( P3I.EQ.ZERO ) THEN + P3 = ABS( P3R ) + DP(1) = SIGN( ONE, P3R ) + DP(2) = ZERO + ELSE + P3 = DLAPY2( P3R, P3I ) + DP(1) = P3R/P3 + DP(2) = -P3I/P3 + END IF +C +C Now compute the quantities v1, v2, v3 and y in (6.13) - (6.15), +C or (10.23) - (10.25). Care is taken to avoid overflows. +C + IF ( DISCR ) THEN + ALPHA = SQRT( ABS( ONE - ABSB )*( ONE + ABSB ) ) + ELSE + ALPHA = SQRT( ABS( TWO*E1 ) ) + END IF +C + SCALOC = ONE + IF( ALPHA.LT.SMIN ) THEN + ALPHA = SMIN + INFO = 1 + END IF + ABST = ABS( P1 ) + IF( ALPHA.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ALPHA ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + P1 = SCALOC*P1 + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V1 = P1/ALPHA +C + IF ( DISCR ) THEN + G(1) = ( ONE - E1 )*( ONE + E1 ) + E2**2 + G(2) = -TWO*E1*E2 + ABSG = DLAPY2( G(1), G(2) ) + SCALOC = ONE + IF( ABSG.LT.SMIN ) THEN + ABSG = SMIN + INFO = 1 + END IF + TEMP(1) = SGN*ALPHA*P2(1) + V1*( E1*T(1) - E2*T(2) ) + TEMP(2) = SGN*ALPHA*P2(2) + V1*( E1*T(2) + E2*T(1) ) + ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + TEMP(1) = SCALOC*TEMP(1) + TEMP(2) = SCALOC*TEMP(2) + P1 = SCALOC*P1 + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + TEMP(1) = TEMP(1)/ABSG + TEMP(2) = TEMP(2)/ABSG +C + SCALOC = ONE + V2(1) = G(1)*TEMP(1) + G(2)*TEMP(2) + V2(2) = G(1)*TEMP(2) - G(2)*TEMP(1) + ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P1 = SCALOC*P1 + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V2(1) = V2(1)/ABSG + V2(2) = V2(2)/ABSG +C + SCALOC = ONE + TEMP(1) = P1*T(1) - TWO*E2*P2(2) + TEMP(2) = P1*T(2) + TWO*E2*P2(1) + ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + TEMP(1) = SCALOC*TEMP(1) + TEMP(2) = SCALOC*TEMP(2) + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + TEMP(1) = TEMP(1)/ABSG + TEMP(2) = TEMP(2)/ABSG +C + SCALOC = ONE + Y(1) = -( G(1)*TEMP(1) + G(2)*TEMP(2) ) + Y(2) = -( G(1)*TEMP(2) - G(2)*TEMP(1) ) + ABST = MAX( ABS( Y(1) ), ABS( Y(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + Y(1) = SCALOC*Y(1) + Y(2) = SCALOC*Y(2) + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + Y(1) = Y(1)/ABSG + Y(2) = Y(2)/ABSG + ELSE +C + SCALOC = ONE + IF( ABSB.LT.SMIN ) THEN + ABSB = SMIN + INFO = 1 + END IF + TEMP(1) = SGN*ALPHA*P2(1) + V1*T(1) + TEMP(2) = SGN*ALPHA*P2(2) + V1*T(2) + ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) + IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSB ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + TEMP(1) = SCALOC*TEMP(1) + TEMP(2) = SCALOC*TEMP(2) + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + TEMP(1) = TEMP(1)/( TWO*ABSB ) + TEMP(2) = TEMP(2)/( TWO*ABSB ) + SCALOC = ONE + V2(1) = -( E1*TEMP(1) + E2*TEMP(2) ) + V2(2) = -( E1*TEMP(2) - E2*TEMP(1) ) + ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) + IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSB ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V2(1) = V2(1)/ABSB + V2(2) = V2(2)/ABSB + Y(1) = P2(1) - ALPHA*V2(1) + Y(2) = P2(2) - ALPHA*V2(2) + END IF +C + SCALOC = ONE + V3 = DLAPY3( P3, Y(1), Y(2) ) + IF( ALPHA.LT.ONE .AND. V3.GT.ONE ) THEN + IF( V3.GT.BIGNUM*ALPHA ) + $ SCALOC = ONE / V3 + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + V3 = SCALOC*V3 + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V3 = V3/ALPHA +C + IF ( LTRANS ) THEN +C +C Case op(M) = M'. +C +C Form X = conjg( Qhat' )*v11. +C + X11(1) = CSQ(1)*V3 + X11(2) = CSQ(2)*V3 + X21(1) = SNQ*V3 + X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) - SNQ*V1 + X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) + X22(1) = CSQ(1)*V1 + SNQ*V2(1) + X22(2) = -CSQ(2)*V1 - SNQ*V2(2) +C +C Obtain u11 from the RQ-factorization of X. The conjugate of +C X22 should be taken. +C + X22(2) = -X22(2) + CALL SB03OV( X22, X21(1), CST, SNT ) + R(2,2) = X22(1) + R(1,2) = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) + TEMPR = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) + TEMPI = CST(1)*X11(2) - CST(2)*X11(1) - SNT*X12(2) + IF ( TEMPI.EQ.ZERO ) THEN + R(1,1) = ABS( TEMPR ) + DT(1) = SIGN( ONE, TEMPR ) + DT(2) = ZERO + ELSE + R(1,1) = DLAPY2( TEMPR, TEMPI ) + DT(1) = TEMPR/R(1,1) + DT(2) = -TEMPI/R(1,1) + END IF + ELSE +C +C Case op(M) = M. +C +C Now form X = v11*conjg( Qhat' ). +C + X11(1) = CSQ(1)*V1 - SNQ*V2(1) + X11(2) = -CSQ(2)*V1 + SNQ*V2(2) + X21(1) = -SNQ*V3 + X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) + SNQ*V1 + X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) + X22(1) = CSQ(1)*V3 + X22(2) = CSQ(2)*V3 +C +C Obtain u11 from the QR-factorization of X. +C + CALL SB03OV( X11, X21(1), CST, SNT ) + R(1,1) = X11(1) + R(1,2) = CST(1)*X12(1) + CST(2)*X12(2) + SNT*X22(1) + TEMPR = CST(1)*X22(1) - CST(2)*X22(2) - SNT*X12(1) + TEMPI = CST(1)*X22(2) + CST(2)*X22(1) - SNT*X12(2) + IF ( TEMPI.EQ.ZERO ) THEN + R(2,2) = ABS( TEMPR ) + DT(1) = SIGN( ONE, TEMPR ) + DT(2) = ZERO + ELSE + R(2,2) = DLAPY2( TEMPR, TEMPI ) + DT(1) = TEMPR/R(2,2) + DT(2) = -TEMPI/R(2,2) + END IF + END IF +C +C The computations below are not needed when B and A are not +C useful. Compute delta, eta and gamma as in (6.21) or (10.26). +C + IF ( ( Y(1).EQ.ZERO ).AND.( Y(2).EQ.ZERO ) ) THEN + DELTA(1) = ZERO + DELTA(2) = ZERO + GAMMA(1) = ZERO + GAMMA(2) = ZERO + ETA = ALPHA + ELSE + DELTA(1) = Y(1)/V3 + DELTA(2) = Y(2)/V3 + GAMMA(1) = -ALPHA*DELTA(1) + GAMMA(2) = -ALPHA*DELTA(2) + ETA = P3/V3 + IF ( DISCR ) THEN + TEMPR = E1*DELTA(1) - E2*DELTA(2) + DELTA(2) = E1*DELTA(2) + E2*DELTA(1) + DELTA(1) = TEMPR + END IF + END IF +C + IF ( LTRANS ) THEN +C +C Case op(M) = M'. +C +C Find X = conjg( That' )*( inv( v11 )*s11hat*v11 ). +C ( Defer the scaling.) +C + X11(1) = CST(1)*E1 + CST(2)*E2 + X11(2) = -CST(1)*E2 + CST(2)*E1 + X21(1) = SNT*E1 + X21(2) = -SNT*E2 + X12(1) = SGN*( CST(1)*GAMMA(1) + CST(2)*GAMMA(2) ) - SNT*E1 + X12(2) = SGN*( -CST(1)*GAMMA(2) + CST(2)*GAMMA(1) ) - SNT*E2 + X22(1) = CST(1)*E1 + CST(2)*E2 + SGN*SNT*GAMMA(1) + X22(2) = CST(1)*E2 - CST(2)*E1 - SGN*SNT*GAMMA(2) +C +C Now find B = X*That. ( Include the scaling here.) +C + S(1,1) = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) + TEMPR = CST(1)*X21(1) + CST(2)*X21(2) - SNT*X22(1) + TEMPI = CST(1)*X21(2) - CST(2)*X21(1) - SNT*X22(2) + S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI + TEMPR = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) + TEMPI = CST(1)*X12(2) + CST(2)*X12(1) + SNT*X11(2) + S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI + S(2,2) = CST(1)*X22(1) - CST(2)*X22(2) + SNT*X21(1) +C +C Form X = ( inv( v11 )*p11 )*conjg( Phat' ). +C + TEMPR = DP(1)*ETA + TEMPI = -DP(2)*ETA + X11(1) = CSP(1)*TEMPR - CSP(2)*TEMPI + SNP*DELTA(1) + X11(2) = CSP(1)*TEMPI + CSP(2)*TEMPR - SNP*DELTA(2) + X21(1) = SNP*ALPHA + X12(1) = -SNP*TEMPR + CSP(1)*DELTA(1) - CSP(2)*DELTA(2) + X12(2) = -SNP*TEMPI - CSP(1)*DELTA(2) - CSP(2)*DELTA(1) + X22(1) = CSP(1)*ALPHA + X22(2) = -CSP(2)*ALPHA +C +C Finally form A = conjg( That' )*X. +C + TEMPR = CST(1)*X11(1) - CST(2)*X11(2) - SNT*X21(1) + TEMPI = CST(1)*X22(2) + CST(2)*X22(1) + A(1,1) = DT(1)*TEMPR + DT(2)*TEMPI + TEMPR = CST(1)*X12(1) - CST(2)*X12(2) - SNT*X22(1) + TEMPI = CST(1)*X12(2) + CST(2)*X12(1) - SNT*X22(1) + A(1,2) = DT(1)*TEMPR + DT(2)*TEMPI + A(2,1) = ZERO + A(2,2) = CST(1)*X22(1) + CST(2)*X22(2) + SNT*X12(1) + ELSE +C +C Case op(M) = M. +C +C Find X = That*( v11*s11hat*inv( v11 ) ). ( Defer the scaling.) +C + X11(1) = CST(1)*E1 + CST(2)*E2 + X11(2) = CST(1)*E2 - CST(2)*E1 + X21(1) = -SNT*E1 + X21(2) = -SNT*E2 + X12(1) = SGN*( CST(1)*GAMMA(1) - CST(2)*GAMMA(2) ) + SNT*E1 + X12(2) = SGN*( -CST(1)*GAMMA(2) - CST(2)*GAMMA(1) ) - SNT*E2 + X22(1) = CST(1)*E1 + CST(2)*E2 - SGN*SNT*GAMMA(1) + X22(2) = -CST(1)*E2 + CST(2)*E1 + SGN*SNT*GAMMA(2) +C +C Now find B = X*conjg( That' ). ( Include the scaling here.) +C + S(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) + TEMPR = CST(1)*X21(1) - CST(2)*X21(2) + SNT*X22(1) + TEMPI = CST(1)*X21(2) + CST(2)*X21(1) + SNT*X22(2) + S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI + TEMPR = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) + TEMPI = CST(1)*X12(2) - CST(2)*X12(1) - SNT*X11(2) + S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI + S(2,2) = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) +C +C Form X = Phat*( p11*inv( v11 ) ). +C + TEMPR = DP(1)*ETA + TEMPI = -DP(2)*ETA + X11(1) = CSP(1)*ALPHA + X11(2) = CSP(2)*ALPHA + X21(1) = SNP*ALPHA + X12(1) = CSP(1)*DELTA(1) + CSP(2)*DELTA(2) - SNP*TEMPR + X12(2) = -CSP(1)*DELTA(2) + CSP(2)*DELTA(1) - SNP*TEMPI + X22(1) = CSP(1)*TEMPR + CSP(2)*TEMPI + SNP*DELTA(1) + X22(2) = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*DELTA(2) +C +C Finally form A = X*conjg( That' ). +C + A(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) + A(2,1) = ZERO + A(1,2) = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) + TEMPR = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) + TEMPI = CST(1)*X22(2) - CST(2)*X22(1) + A(2,2) = DT(1)*TEMPR + DT(2)*TEMPI + END IF +C + IF( SCALE.NE.ONE ) THEN + A(1,1) = SCALE*A(1,1) + A(1,2) = SCALE*A(1,2) + A(2,2) = SCALE*A(2,2) + END IF +C + RETURN +C *** Last line of SB03OY *** + END diff --git a/modules/cacsd/src/slicot/sb03oy.lo b/modules/cacsd/src/slicot/sb03oy.lo new file mode 100755 index 000000000..23430fe46 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03oy.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03oy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03oy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03qx.f b/modules/cacsd/src/slicot/sb03qx.f new file mode 100755 index 000000000..672d7f0bc --- /dev/null +++ b/modules/cacsd/src/slicot/sb03qx.f @@ -0,0 +1,375 @@ + SUBROUTINE SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 +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 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, 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 ) + 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 ) + END IF +C + IF( KASE.EQ.1 ) THEN + IJ = 0 + IF( LOWER ) THEN +C +C Scale the lower triangular part of symmetric matrix +C by the residual matrix. +C + DO 70 J = 1, N + DO 60 I = J, N + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 60 CONTINUE + IJ = IJ + J + 70 CONTINUE + ELSE +C +C Scale the upper triangular part of symmetric matrix +C by the residual matrix. +C + DO 90 J = 1, N + DO 80 I = 1, J + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 80 CONTINUE + IJ = IJ + N - J + 90 CONTINUE + END IF + END IF +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLOW, N, DWORK, N ) + GO TO 10 + END IF +C +C UNTIL KASE = 0 +C +C Compute the estimate of the relative error. +C + TEMP = XANORM*SCALE + IF( TEMP.GT.EST ) THEN + FERR = EST / TEMP + ELSE + FERR = ONE + END IF +C + RETURN +C +C *** Last line of SB03QX *** + END diff --git a/modules/cacsd/src/slicot/sb03qx.lo b/modules/cacsd/src/slicot/sb03qx.lo new file mode 100755 index 000000000..9d72e6b20 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03qx.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03qx.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03qx.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03qy.f b/modules/cacsd/src/slicot/sb03qy.f new file mode 100755 index 000000000..3baf7c9a6 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03qy.f @@ -0,0 +1,422 @@ + SUBROUTINE SB03QY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, + $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 +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 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, 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 ) + 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 ) +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 ) + 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 ) +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLO, N, DWORK, N ) + END IF +C + GO TO 20 + END IF +C UNTIL KASE = 0 +C + IF( EST.LT.SCALE ) THEN + THNORM = EST / SCALE + ELSE + BIGNUM = ONE / DLAMCH( 'Safe minimum' ) + IF( EST.LT.SCALE*BIGNUM ) THEN + THNORM = EST / SCALE + ELSE + THNORM = BIGNUM + END IF + END IF + END IF +C + RETURN +C *** Last line of SB03QY *** + END diff --git a/modules/cacsd/src/slicot/sb03qy.lo b/modules/cacsd/src/slicot/sb03qy.lo new file mode 100755 index 000000000..cba7db6f2 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03qy.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03qy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03qy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03sx.f b/modules/cacsd/src/slicot/sb03sx.f new file mode 100755 index 000000000..157cab213 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03sx.f @@ -0,0 +1,379 @@ + SUBROUTINE SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 +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 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, 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 ) + 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 ) + END IF +C + IF( KASE.EQ.1 ) THEN + IJ = 0 + IF( LOWER ) THEN +C +C Scale the lower triangular part of symmetric matrix +C by the residual matrix. +C + DO 70 J = 1, N + DO 60 I = J, N + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 60 CONTINUE + IJ = IJ + J + 70 CONTINUE + ELSE +C +C Scale the upper triangular part of symmetric matrix +C by the residual matrix. +C + DO 90 J = 1, N + DO 80 I = 1, J + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 80 CONTINUE + IJ = IJ + N - J + 90 CONTINUE + END IF + END IF +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLOW, N, DWORK, N ) + GO TO 10 + END IF +C +C UNTIL KASE = 0 +C +C Compute the estimate of the relative error. +C + TEMP = XANORM*SCALE + IF( TEMP.GT.EST ) THEN + FERR = EST / TEMP + ELSE + FERR = ONE + END IF +C + RETURN +C +C *** Last line of SB03SX *** + END diff --git a/modules/cacsd/src/slicot/sb03sx.lo b/modules/cacsd/src/slicot/sb03sx.lo new file mode 100755 index 000000000..15d067371 --- /dev/null +++ b/modules/cacsd/src/slicot/sb03sx.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03sx.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03sx.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb03sy.f b/modules/cacsd/src/slicot/sb03sy.f new file mode 100755 index 000000000..bdfdd356a --- /dev/null +++ b/modules/cacsd/src/slicot/sb03sy.f @@ -0,0 +1,430 @@ + SUBROUTINE SB03SY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, XA, + $ LDXA, SEPD, THNORM, IWORK, DWORK, LDWORK, + $ INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 +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 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, 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 ) + 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 ) +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 ) + 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 ) +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLO, N, DWORK, N ) + END IF +C + GO TO 20 + END IF +C UNTIL KASE = 0 +C + IF( EST.LT.SCALE ) THEN + THNORM = EST / SCALE + ELSE + BIGNUM = ONE / DLAMCH( 'Safe minimum' ) + IF( EST.LT.SCALE*BIGNUM ) THEN + THNORM = EST / SCALE + ELSE + THNORM = BIGNUM + END IF + END IF + END IF +C + RETURN +C *** Last line of SB03SY *** + END diff --git a/modules/cacsd/src/slicot/sb03sy.lo b/modules/cacsd/src/slicot/sb03sy.lo new file mode 100755 index 000000000..686b3332a --- /dev/null +++ b/modules/cacsd/src/slicot/sb03sy.lo @@ -0,0 +1,12 @@ +# src/slicot/sb03sy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb03sy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04md.f b/modules/cacsd/src/slicot/sb04md.f new file mode 100755 index 000000000..175f2c67f --- /dev/null +++ b/modules/cacsd/src/slicot/sb04md.f @@ -0,0 +1,331 @@ + SUBROUTINE SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, + $ DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve for X the continuous-time Sylvester equation +C +C AX + XB = C +C +C where A, B, C and X are general N-by-N, M-by-M, N-by-M and +C N-by-M matrices respectively. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A of the equation. +C On exit, the leading N-by-N upper Hessenberg part of this +C array contains the matrix H, and the remainder of the +C leading N-by-N part, together with the elements 2,3,...,N +C of array DWORK, contain the orthogonal transformation +C matrix U (stored in factored form). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix B of the equation. +C On exit, the leading M-by-M part of this array contains +C the quasi-triangular Schur factor S of the matrix B'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading N-by-M part of this array contains +C the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) +C The leading M-by-M part of this array contains the +C orthogonal matrix Z used to transform B' to real upper +C Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,M). +C +C Workspace +C +C IWORK INTEGER array, dimension (4*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain +C the scalar factors of the elementary reflectors used to +C reduce A to upper Hessenberg form, as returned by LAPACK +C Library routine DGEHRD. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = MAX(1, 2*N*N + 8*N, 5*M, N + M). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to +C compute all the eigenvalues (see LAPACK Library +C routine DGEES); +C > M: if a singular matrix was encountered whilst solving +C for the (INFO-M)-th column of matrix X. +C +C METHOD +C +C The matrix A is transformed to upper Hessenberg form H = U'AU by +C the orthogonal transformation matrix U; matrix B' is transformed +C to real upper Schur form S = Z'B'Z using the orthogonal +C transformation matrix Z. The matrix C is also multiplied by the +C transformations, F = U'CZ, and the solution matrix Y of the +C transformed system +C +C HY + YS' = F +C +C is computed by back substitution. Finally, the matrix Y is then +C multiplied by the orthogonal transformation matrices, X = UYZ', in +C order to obtain the solution matrix X to the original problem. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C 3 3 2 2 +C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N +C operations and is backward stable. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04AD by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000, Aug. 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER I, IEIG, IFAIL, IHI, ILO, IND, ITAU, JWORK, + $ SDIM, WRKOPT +C .. Local Scalars .. + LOGICAL SELECT +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, + $ DORMHR, DSWAP, SB04MU, SB04MY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 8*N, 5*M, N + M ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ILO = 1 + IHI = N + WRKOPT = 1 +C +C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper +C triangular. That is, H = U' * A * U (store U in factored +C form) and S = Z' * B' * Z (save Z). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 20 I = 2, M + CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) + 20 CONTINUE +C +C Workspace: need 5*M; +C prefer larger. +C + IEIG = M + 1 + JWORK = IEIG + M + CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, + $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), + $ LDWORK-JWORK+1, BWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need 2*N; +C prefer N + N*NB. +C + ITAU = 2 + JWORK = ITAU + N - 1 + CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN + CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, + $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) + WRKOPT = MAX( WRKOPT, JWORK - 1 + N*M ) + ELSE +C + DO 40 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 40 CONTINUE +C + END IF +C + IND = M + 60 CONTINUE + IF ( IND.GT.1 ) THEN +C +C Step 3 : Solve H * Y + Y * S' = F for Y. +C + IF ( B(IND,IND-1).EQ.ZERO ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N. +C + CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) + IND = IND - 1 + ELSE +C +C Solve a special linear algebraic system of order 2*N. +C Workspace: 2*N*N + 8*N; +C + CALL SB04MU( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + 2*N*N + 7*N - 1 ) + IND = IND - 2 + END IF + GO TO 60 + ELSE IF ( IND.EQ.1 ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N; +C + CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) + END IF +C +C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN + CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, + $ Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) + ELSE +C + DO 80 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 80 CONTINUE + END IF +C + RETURN +C *** Last line of SB04MD *** + END diff --git a/modules/cacsd/src/slicot/sb04md.lo b/modules/cacsd/src/slicot/sb04md.lo new file mode 100755 index 000000000..df0435e56 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04md.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04md.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04md.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04mr.f b/modules/cacsd/src/slicot/sb04mr.f new file mode 100755 index 000000000..36fdd1ddb --- /dev/null +++ b/modules/cacsd/src/slicot/sb04mr.f @@ -0,0 +1,206 @@ + SUBROUTINE SB04MR( M, D, IPR, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix has zeros below the second subdiagonal. The matrix is +C stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0. +C Note that parameter M should have twice the value in the +C original problem (see SLICOT Library routine SB04MU). +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*(M+1)/2+3*M) +C On entry, the first M*(M+1)/2 + 2*M elements of this array +C must contain the coefficient matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04MU. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AR by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, + $ MPI2 + DOUBLE PRECISION D1, D2, D3, DMAX +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + I2 = ( M*( M + 5 ) )/2 + MPI = M + IPRM = I2 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GE.3 ) M1 = M1 - 1 + 20 CONTINUE +C + M1 = M - 1 + MPI1 = M + 1 +C +C Reduce to upper triangular form. +C + DO 80 I = 1, M1 + MPI = MPI1 + MPI1 = MPI1 + 1 + IPRM = IPR(MPI) + D1 = D(IPRM) + I1 = 2 + IF ( I.EQ.M1 ) I1 = 1 + MPI2 = MPI + I1 + L = 0 + DMAX = ABS( D1 ) +C + DO 40 J = MPI1, MPI2 + D2 = D(IPR(J)) + D3 = ABS( D2 ) + IF ( D3.GT.DMAX ) THEN + DMAX = D3 + D1 = D2 + L = J - MPI + END IF + 40 CONTINUE +C +C Check singularity. +C + IF ( DMAX.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + IF ( L.GT.0 ) THEN +C +C Permute the row indices. +C + K = IPRM + J = MPI + L + IPRM = IPR(J) + IPR(J) = K + IPR(MPI) = IPRM + K = IPR(I) + I2 = I + L + IPR(I) = IPR(I2) + IPR(I2) = K + END IF + IPRM = IPRM + 1 +C +C Annihilate the subdiagonal elements of the matrix. +C + I2 = I + D3 = D(IPR(I)) +C + DO 60 J = MPI1, MPI2 + I2 = I2 + 1 + IPRM1 = IPR(J) + DMAX = -D(IPRM1)/D1 + D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 + CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) + 60 CONTINUE +C + IPR(MPI1) = IPR(MPI1) + 1 + IF ( I.NE.M1 ) IPR(MPI2) = IPR(MPI2) + 1 + 80 CONTINUE +C + MPI = M + M + IPRM = IPR(MPI) +C +C Check singularity. +C + IF ( D(IPRM).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPRM) +C + DO 120 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + DMAX = ZERO +C + DO 100 K = I+1, M + IPRM1 = IPRM1 + 1 + DMAX = DMAX + D(IPR(K))*D(IPRM1) + 100 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) + 120 CONTINUE +C + RETURN +C *** Last line of SB04MR *** + END diff --git a/modules/cacsd/src/slicot/sb04mr.lo b/modules/cacsd/src/slicot/sb04mr.lo new file mode 100755 index 000000000..1d76b1d78 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04mr.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04mr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04mr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04mu.f b/modules/cacsd/src/slicot/sb04mu.f new file mode 100755 index 000000000..378482b63 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04mu.f @@ -0,0 +1,174 @@ + SUBROUTINE SB04MU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order 2*M +C whose coefficient matrix has zeros below the second subdiagonal. +C Such systems appear when solving continuous-time Sylvester +C equations using the Hessenberg-Schur method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C IND and IND - 1 specify the indices of the columns in C +C to be computed. IND > 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with columns IND-1 and IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (2*M*M+7*M) +C +C IPR INTEGER array, dimension (4*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order 2*M, whose coefficient +C matrix has zeros below the second subdiagonal is constructed and +C solved. The coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AU by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, IND1, J, K, K1, K2, M2 + DOUBLE PRECISION TEMP +C .. External Subroutines .. + EXTERNAL DAXPY, SB04MR +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + IND1 = IND - 1 +C + DO 20 I = IND + 1, N + CALL DAXPY( M, -B(IND1,I), C(1,I), 1, C(1,IND1), 1 ) + CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) + 20 CONTINUE +C +C Construct the linear algebraic system of order 2*M. +C + K1 = -1 + M2 = 2*M + I2 = M*(M2 + 5) + K = M2 +C + DO 60 I = 1, M +C + DO 40 J = MAX( 1, I - 1 ), M + K1 = K1 + 2 + K2 = K1 + K + TEMP = A(I,J) + IF ( I.NE.J ) THEN + D(K1) = TEMP + D(K1+1) = ZERO + IF ( J.GT.I ) D(K2) = ZERO + D(K2+1) = TEMP + ELSE + D(K1) = TEMP + B(IND1,IND1) + D(K1+1) = B(IND1,IND) + D(K2) = B(IND,IND1) + D(K2+1) = TEMP + B(IND,IND) + END IF + 40 CONTINUE +C + K1 = K2 + K = K - MIN( 2, I ) +C +C Store the right hand side. +C + I2 = I2 + 2 + D(I2) = C(I,IND) + D(I2-1) = C(I,IND1) + 60 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MR( M2, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE + I2 = 0 +C + DO 80 I = 1, M + I2 = I2 + 2 + C(I,IND1) = D(IPR(I2-1)) + C(I,IND) = D(IPR(I2)) + 80 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04MU *** + END diff --git a/modules/cacsd/src/slicot/sb04mu.lo b/modules/cacsd/src/slicot/sb04mu.lo new file mode 100755 index 000000000..b4a7b5d7e --- /dev/null +++ b/modules/cacsd/src/slicot/sb04mu.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04mu.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04mu.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04mw.f b/modules/cacsd/src/slicot/sb04mw.f new file mode 100755 index 000000000..35385c04a --- /dev/null +++ b/modules/cacsd/src/slicot/sb04mw.f @@ -0,0 +1,178 @@ + SUBROUTINE SB04MW( M, D, IPR, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix is in upper Hessenberg form, stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*(M+1)/2+2*M) +C On entry, the first M*(M+1)/2 + M elements of this array +C must contain an upper Hessenberg matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04MY. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AW by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, IPRM, IPRM1, K, M1, M2, MPI + DOUBLE PRECISION D1, D2, MULT +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + M1 = ( M*( M + 3 ) )/2 + M2 = M + M + MPI = M + IPRM = M1 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GT.1 ) M1 = M1 - 1 + 20 CONTINUE +C + M1 = M - 1 + MPI = M +C +C Reduce to upper triangular form. +C + DO 40 I = 1, M1 + I1 = I + 1 + MPI = MPI + 1 + IPRM = IPR(MPI) + IPRM1 = IPR(MPI+1) + D1 = D(IPRM) + D2 = D(IPRM1) + IF ( ABS( D1 ).LE.ABS( D2 ) ) THEN +C +C Permute the row indices. +C + K = IPRM + IPR(MPI) = IPRM1 + IPRM = IPRM1 + IPRM1 = K + K = IPR(I) + IPR(I) = IPR(I1) + IPR(I1) = K + D1 = D2 + END IF +C +C Check singularity. +C + IF ( D1.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + MULT = -D(IPRM1)/D1 + IPRM1 = IPRM1 + 1 + IPR(MPI+1) = IPRM1 +C +C Annihilate the subdiagonal elements of the matrix. +C + D(IPR(I1)) = D(IPR(I1)) + MULT*D(IPR(I)) + CALL DAXPY( M-I, MULT, D(IPRM+1), 1, D(IPRM1), 1 ) + 40 CONTINUE +C +C Check singularity. +C + IF ( D(IPR(M2)).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPR(M2)) + MPI = M2 +C + DO 80 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + MULT = ZERO +C + DO 60 I1 = I + 1, M + IPRM1 = IPRM1 + 1 + MULT = MULT + D(IPR(I1))*D(IPRM1) + 60 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - MULT )/D(IPRM) + 80 CONTINUE +C + RETURN +C *** Last line of SB04MW *** + END diff --git a/modules/cacsd/src/slicot/sb04mw.lo b/modules/cacsd/src/slicot/sb04mw.lo new file mode 100755 index 000000000..71675aaaa --- /dev/null +++ b/modules/cacsd/src/slicot/sb04mw.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04mw.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04mw.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04my.f b/modules/cacsd/src/slicot/sb04my.f new file mode 100755 index 000000000..07b758435 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04my.f @@ -0,0 +1,152 @@ + SUBROUTINE SB04MY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order M whose +C coefficient matrix is in upper Hessenberg form. Such systems +C appear when solving Sylvester equations using the Hessenberg-Schur +C method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C The index of the column in C to be computed. IND >= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with column IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) +C +C IPR INTEGER array, dimension (2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order M, with coefficient +C matrix in upper Hessenberg form is constructed and solved. The +C coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AY by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, J, K, K1, K2, M1 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, SB04MW +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + DO 20 I = IND + 1, N + CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) + 20 CONTINUE +C + M1 = M + 1 + I2 = ( M*M1 )/2 + M1 + K2 = 1 + K = M +C +C Construct the linear algebraic system of order M. +C + DO 40 I = 1, M + J = M1 - K + CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) + K1 = K2 + K2 = K2 + K + IF ( I.GT.1 ) THEN + K1 = K1 + 1 + K = K - 1 + END IF + D(K1) = D(K1) + B(IND,IND) +C +C Store the right hand side. +C + D(I2) = C(I,IND) + I2 = I2 + 1 + 40 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MW( M, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE +C + DO 60 I = 1, M + C(I,IND) = D(IPR(I)) + 60 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04MY *** + END diff --git a/modules/cacsd/src/slicot/sb04my.lo b/modules/cacsd/src/slicot/sb04my.lo new file mode 100755 index 000000000..2814d19db --- /dev/null +++ b/modules/cacsd/src/slicot/sb04my.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04my.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04my.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04nd.f b/modules/cacsd/src/slicot/sb04nd.f new file mode 100755 index 000000000..e4dc97eb0 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04nd.f @@ -0,0 +1,389 @@ + SUBROUTINE SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, + $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve for X the continuous-time Sylvester equation +C +C AX + XB = C, +C +C with at least one of the matrices A or B in Schur form and the +C other in Hessenberg or Schur form (both either upper or lower); +C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, +C respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHU CHARACTER*1 +C Indicates whether A and/or B is/are in Schur or +C Hessenberg form as follows: +C = 'A': A is in Schur form, B is in Hessenberg form; +C = 'B': B is in Schur form, A is in Hessenberg form; +C = 'S': Both A and B are in Schur form. +C +C ULA CHARACTER*1 +C Indicates whether A is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and +C upper Schur form otherwise; +C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and +C lower Schur form otherwise. +C +C ULB CHARACTER*1 +C Indicates whether B is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and +C upper Schur form otherwise; +C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and +C lower Schur form otherwise. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C coefficient matrix A of the equation. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading M-by-M part of this array must contain the +C coefficient matrix B of the equation. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, if INFO = 0, the leading N-by-M part of this +C array contains the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity in +C the Sylvester equation. If the user sets TOL > 0, then the +C given value of TOL is used as a lower bound for the +C reciprocal condition number; a matrix whose estimated +C condition number is less than 1/TOL is considered to be +C nonsingular. If the user sets TOL <= 0, then a default +C tolerance, defined by TOLDEF = EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*MAX(M,N)) +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = 0, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; +C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if a (numerically) singular matrix T was encountered +C during the computation of the solution matrix X. +C That is, the estimated reciprocal condition number +C of T is less than or equal to TOL. +C +C METHOD +C +C Matrices A and B are assumed to be in (upper or lower) Hessenberg +C or Schur form (with at least one of them in Schur form). The +C solution matrix X is then computed by rows or columns via the back +C substitution scheme proposed by Golub, Nash and Van Loan (see +C [1]), which involves the solution of triangular systems of +C equations that are constructed recursively and which may be nearly +C singular if A and -B have close eigenvalues. If near singularity +C is detected, then the routine returns with the Error Indicator +C (INFO) set to 1. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C 2 2 +C The algorithm requires approximately 5M N + 0.5MN operations in +C 2 2 +C the worst case and 2.5M N + 0.5MN operations in the best case +C (where M is the order of the matrix in Hessenberg form and N is +C the order of the matrix in Schur form) and is mixed stable (see +C [1]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHU, ULA, ULB + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) +C .. Local Scalars .. + CHARACTER ABSCHR + LOGICAL LABSCB, LABSCS, LULA, LULB + INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, + $ LDW, MAXMN + DOUBLE PRECISION SCALE, TOL1 +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DTRSYL, SB04NV, SB04NW, SB04NX, SB04NY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + MAXMN = MAX( M, N ) + LABSCB = LSAME( ABSCHU, 'B' ) + LABSCS = LSAME( ABSCHU, 'S' ) + LULA = LSAME( ULA, 'U' ) + LULB = LSAME( ULB, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. + $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.0 .OR. ( .NOT.( LABSCS .AND. LULA .AND. LULB ) + $ .AND. LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) ) ) THEN + INFO = -15 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAXMN.EQ.0 ) + $ RETURN +C + IF ( LABSCS .AND. LULA .AND. LULB ) THEN +C +C If both matrices are in a real Schur form, use DTRSYL. +C + CALL DTRSYL( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, B, + $ LDB, C, LDC, SCALE, INFO ) + IF ( SCALE.NE.ONE ) + $ INFO = 1 + RETURN + END IF +C + LDW = 2*MAXMN + JWORK = LDW*LDW + 3*LDW + 1 + TOL1 = TOL + IF ( TOL1.LE.ZERO ) + $ TOL1 = DLAMCH( 'Epsilon' ) +C +C Choose the smallest of both matrices as the one in Hessenberg +C form when possible. +C + ABSCHR = ABSCHU + IF ( LABSCS ) THEN + IF ( N.GT.M ) THEN + ABSCHR = 'A' + ELSE + ABSCHR = 'B' + END IF + END IF + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C B is in Schur form: recursion on the columns of B. +C + IF ( LULB ) THEN +C +C B is upper: forward recursion. +C + IBEG = 1 + IEND = M + FWD = 1 + INCR = 0 + ELSE +C +C B is lower: backward recursion. +C + IBEG = M + IEND = 1 + FWD = -1 + INCR = -1 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( B(I+FWD,I).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04NW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, + $ DWORK(JWORK) ) + CALL SB04NY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) + ELSE + IPINCR = I + INCR + CALL SB04NV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, + $ DWORK(JWORK) ) + CALL SB04NX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), + $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), + $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) + CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) + END IF + I = I + FWD*ISTEP + GO TO 20 + END IF +C END WHILE 20 + ELSE +C +C A is in Schur form: recursion on the rows of A. +C + IF ( LULA ) THEN +C +C A is upper: backward recursion. +C + IBEG = N + IEND = 1 + FWD = -1 + INCR = -1 + ELSE +C +C A is lower: forward recursion. +C + IBEG = 1 + IEND = N + FWD = 1 + INCR = 0 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( A(I,I+FWD).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04NW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, + $ DWORK(JWORK) ) + CALL SB04NY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + ELSE + IPINCR = I + INCR + CALL SB04NV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, + $ DWORK(JWORK) ) + CALL SB04NX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), + $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), + $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) + CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) + END IF + I = I + FWD*ISTEP + GO TO 40 + END IF +C END WHILE 40 + END IF +C + RETURN +C *** Last line of SB04ND *** + END diff --git a/modules/cacsd/src/slicot/sb04nd.lo b/modules/cacsd/src/slicot/sb04nd.lo new file mode 100755 index 000000000..98e2b7e16 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04nd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04nd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04nd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04nv.f b/modules/cacsd/src/slicot/sb04nv.f new file mode 100755 index 000000000..1be7cd4a3 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04nv.f @@ -0,0 +1,149 @@ + SUBROUTINE SB04NV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To construct the right-hand sides D for a system of equations in +C Hessenberg form solved via SB04NX (case with 2 right-hand sides). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation AX + XB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the first column/row of C to be used in +C the construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C AX + XB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading 2*N or 2*M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side stored as a matrix with two rows. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BV by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the 2 columns of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) + CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, + $ ONE, D(1), 2 ) + CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX+1), + $ 1, ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.LT.M-1 ) THEN + CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX), 1, ONE, D(1), 2 ) + CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX+1), 1, ONE, D(2), 2 ) + END IF + END IF + ELSE +C +C Construct the 2 rows of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) + CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N-1 ) THEN + CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, + $ AB(INDX,INDX+2), LDAB, ONE, D(1), 2 ) + CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, + $ AB(INDX+1,INDX+2), LDAB, ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), + $ LDAB, ONE, D(1), 2 ) + CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX+1,1), + $ LDAB, ONE, D(2), 2 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04NV *** + END diff --git a/modules/cacsd/src/slicot/sb04nv.lo b/modules/cacsd/src/slicot/sb04nv.lo new file mode 100755 index 000000000..2fc630d0c --- /dev/null +++ b/modules/cacsd/src/slicot/sb04nv.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04nv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04nv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04nw.f b/modules/cacsd/src/slicot/sb04nw.f new file mode 100755 index 000000000..800126a78 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04nw.f @@ -0,0 +1,139 @@ + SUBROUTINE SB04NW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To construct the right-hand side D for a system of equations in +C Hessenberg form solved via SB04NY (case with 1 right-hand side). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation AX + XB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the column/row of C to be used in the +C construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C AX + XB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading N or M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BW by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the column of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, + $ ONE, D, 1 ) + END IF + ELSE + IF ( INDX.LT.M ) THEN + CALL DGEMV( 'N', N, M-INDX, -ONE, C(1,INDX+1), LDC, + $ AB(INDX+1,INDX), 1, ONE, D, 1 ) + END IF + END IF + ELSE +C +C Construct the row of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N ) THEN + CALL DGEMV( 'T', N-INDX, M, -ONE, C(INDX+1,1), LDC, + $ AB(INDX,INDX+1), LDAB, ONE, D, 1 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), + $ LDAB, ONE, D, 1 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04NW *** + END diff --git a/modules/cacsd/src/slicot/sb04nw.lo b/modules/cacsd/src/slicot/sb04nw.lo new file mode 100755 index 000000000..4e0deb934 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04nw.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04nw.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04nw.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04nx.f b/modules/cacsd/src/slicot/sb04nx.f new file mode 100755 index 000000000..d8fcb6e1b --- /dev/null +++ b/modules/cacsd/src/slicot/sb04nx.f @@ -0,0 +1,304 @@ + SUBROUTINE SB04NX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, + $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve a system of equations in Hessenberg form with two +C consecutive offdiagonals and two right-hand sides. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBD1, (input) DOUBLE PRECISION +C LAMBD2, These variables must contain the 2-by-2 block to be added +C LAMBD3, to the diagonal blocks of A. +C LAMBD4 +C +C D (input/output) DOUBLE PRECISION array, dimension (2*M) +C On entry, this array must contain the two right-hand +C side vectors of the Hessenberg system, stored row-wise. +C On exit, if INFO = 0, this array contains the two solution +C vectors of the Hessenberg system, stored row-wise. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the Hessenberg matrix. A matrix +C whose estimated condition number is less than 1/TOL is +C considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) +C The leading 2*M-by-2*M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the Hessenberg matrix. The remaining 6*M elements are +C used as workspace for the computation of the reciprocal +C condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. +C LDDWOR >= MAX(1,2*M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Hessenberg matrix is (numerically) singular. +C That is, its estimated reciprocal condition number +C is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BX by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M and LDA must be such that the value of the +C LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, 2*M ) ) +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, J2, M2, MJ, ML + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DLASET, DROT, DTRCON, DTRSV +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + M2 = M*2 + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + J2 = J*2 + ML = MIN( M, J + 1 ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 + DWORK(J2,J2-1) = LAMBD3 + DWORK(J2-1,J2) = LAMBD2 + DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J+2,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) + DWORK(J+1,J) = R + DWORK(J+2,J) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, + $ DWORK(J+2,J+1), LDDWOR, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, + $ S, R ) + DWORK(MJ+1,MJ) = R + DWORK(MJ+1,MJ-1) = ZERO + CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, + $ S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J2 = J*2 + J1 = MAX( J - 1, 1 ) + ML = MIN( M - J + 2, M ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 + DWORK(J2,J2-1) = LAMBD3 + DWORK(J2-1,J2) = LAMBD2 + DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, + $ S, R ) + DWORK(MJ,MJ+1) = R + DWORK(MJ-1,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J,J+2).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) + DWORK(J,J+1) = R + DWORK(J,J+2) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), + $ 1, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, + $ DWORK(1,M2+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04NX *** + END diff --git a/modules/cacsd/src/slicot/sb04nx.lo b/modules/cacsd/src/slicot/sb04nx.lo new file mode 100755 index 000000000..ff495ace6 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04nx.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04nx.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04nx.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04ny.f b/modules/cacsd/src/slicot/sb04ny.f new file mode 100755 index 000000000..0ad905916 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04ny.f @@ -0,0 +1,244 @@ + SUBROUTINE SB04NY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, + $ DWORK, LDDWOR, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To solve a system of equations in Hessenberg form with one +C offdiagonal and one right-hand side. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBDA (input) DOUBLE PRECISION +C This variable must contain the value to be added to the +C diagonal elements of A. +C +C D (input/output) DOUBLE PRECISION array, dimension (M) +C On entry, this array must contain the right-hand side +C vector of the Hessenberg system. +C On exit, if INFO = 0, this array contains the solution +C vector of the Hessenberg system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the Hessenberg matrix. A matrix +C whose estimated condition number is less than 1/TOL is +C considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) +C The leading M-by-M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the Hessenberg matrix. The remaining 3*M elements are +C used as workspace for the computation of the reciprocal +C condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Hessenberg matrix is (numerically) singular. +C That is, its estimated reciprocal condition number +C is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BY by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M and LDA must be such that the value of the +C LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, M ) ) +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBDA, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, MJ + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DROT, DTRCON, DTRSV +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + LAMBDA + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J1 = MAX( J - 1, 1 ) + CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + LAMBDA + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) +C + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, + $ DWORK(1,M+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04NY *** + END diff --git a/modules/cacsd/src/slicot/sb04ny.lo b/modules/cacsd/src/slicot/sb04ny.lo new file mode 100755 index 000000000..a4e356326 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04ny.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04ny.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04ny.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04pd.f b/modules/cacsd/src/slicot/sb04pd.f new file mode 100755 index 000000000..3d69c805e --- /dev/null +++ b/modules/cacsd/src/slicot/sb04pd.f @@ -0,0 +1,656 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 2000. +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, SELECT1 + EXTERNAL LSAME, SELECT1 +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', SELECT1, 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', SELECT1, N, B, LDB, SDIM, + $ DWORK( IA ), DWORK( N+IA ), V, LDV, DWORK( JWORK ), + $ AVAILW, BWORK, IERR ) + IF( IERR.GT.0 ) THEN + INFO = IERR + M + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) +C + IF( .NOT.SCHURA ) THEN +C +C Recompute the blocking parameters. +C + CHUNKA = AVAILW / M + BLOCKA = MIN( CHUNKA, N ).GT.1 + BLAS3A = CHUNKA.GE.N .AND. BLOCKA + END IF + END IF +C + IF( .NOT.SCHURB ) THEN +C +C Transform the right-hand side: C <-- C*V. +C Workspace: need a+b+N, +C prefer a+b+M*N, +C where b = 2*N, if FACTB = 'N', FACTA = 'N', +C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', +C b = 0, if FACTB <> 'N'. +C + CHUNKB = AVAILW / N + BLOCKB = MIN( CHUNKB, M ).GT.1 + BLAS3B = CHUNKB.GE.M .AND. BLOCKB +C + IF ( BLAS3B ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE, + $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) + ELSE IF ( BLOCKB ) THEN +C +C Use as many rows of C as possible. +C + DO 30 I = 1, M, CHUNKB + BL = MIN( M-I+1, CHUNKB ) + CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, + $ DWORK( JWORK ), BL ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, + $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), + $ LDC ) + 30 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 40 I = 1, M + CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, + $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) + 40 CONTINUE +C + END IF + MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) + END IF +C +C Solve the (transformed) equation. +C Workspace for DICO = 'D': a+b+2*M. +C + IF ( CONT ) THEN + CALL DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, + $ SCALE, IERR ) + ELSE + CALL SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, + $ SCALE, DWORK( JWORK ), IERR ) + MAXWRK = MAX( MAXWRK, JWORK + 2*M - 1 ) + END IF + IF( IERR.GT.0 ) + $ INFO = M + N + 1 +C +C Transform back the solution, if needed. +C + IF( .NOT.SCHURA ) THEN +C +C Transform the right-hand side: C <-- U*C. +C Workspace: need a+b+M; +C prefer a+b+M*N. +C + IF ( BLAS3A ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, + $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) + ELSE IF ( BLOCKA ) THEN +C +C Use as many columns of C as possible. +C + DO 50 J = 1, N, CHUNKA + BL = MIN( N-J+1, CHUNKA ) + CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, + $ DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, + $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), + $ LDC ) + 50 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 60 J = 1, N + CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) + CALL DGEMV( 'NoTranspose', M, M, ONE, U, LDU, + $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) + 60 CONTINUE +C + END IF + END IF +C + IF( .NOT.SCHURB ) THEN +C +C Transform the right-hand side: C <-- C*V'. +C Workspace: need a+b+N; +C prefer a+b+M*N. +C + IF ( BLAS3B ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, ONE, + $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) + ELSE IF ( BLOCKB ) THEN +C +C Use as many rows of C as possible. +C + DO 70 I = 1, M, CHUNKB + BL = MIN( M-I+1, CHUNKB ) + CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, + $ DWORK( JWORK ), BL ) + CALL DGEMM( 'NoTranspose', 'Transpose', BL, N, N, ONE, + $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), + $ LDC ) + 70 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 80 I = 1, M + CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) + CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, + $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) + 80 CONTINUE +C + END IF + END IF +C + DWORK( 1 ) = DBLE( MAXWRK ) +C + RETURN +C *** Last line of SB04PD *** + END diff --git a/modules/cacsd/src/slicot/sb04pd.lo b/modules/cacsd/src/slicot/sb04pd.lo new file mode 100755 index 000000000..6da5cb640 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04pd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04pd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04pd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04px.f b/modules/cacsd/src/slicot/sb04px.f new file mode 100755 index 000000000..59217dbfe --- /dev/null +++ b/modules/cacsd/src/slicot/sb04px.f @@ -0,0 +1,452 @@ + SUBROUTINE SB04PX( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, + $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in +C +C op(TL)*X*op(TR) + ISGN*X = SCALE*B, +C +C where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1 +C or -1. op(T) = T or T', where T' denotes the transpose of T. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRANL LOGICAL +C Specifies the form of op(TL) to be used, as follows: +C = .FALSE.: op(TL) = TL, +C = .TRUE. : op(TL) = TL'. +C +C LTRANR LOGICAL +C Specifies the form of op(TR) to be used, as follows: +C = .FALSE.: op(TR) = TR, +C = .TRUE. : op(TR) = TR'. +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The order of matrix TL. N1 may only be 0, 1 or 2. +C +C N2 (input) INTEGER +C The order of matrix TR. N2 may only be 0, 1 or 2. +C +C TL (input) DOUBLE PRECISION array, dimension (LDTL,N1) +C The leading N1-by-N1 part of this array must contain the +C matrix TL. +C +C LDTL INTEGER +C The leading dimension of array TL. LDTL >= MAX(1,N1). +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,N2) +C The leading N2-by-N2 part of this array must contain the +C matrix TR. +C +C LDTR INTEGER +C The leading dimension of array TR. LDTR >= MAX(1,N2). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N2) +C The leading N1-by-N2 part of this array must contain the +C right-hand side of the equation. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor. SCALE is chosen less than or equal to 1 +C to prevent the solution overflowing. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N2) +C The leading N1-by-N2 part of this array contains the +C solution of the equation. +C Note that X may be identified with B in the calling +C statement. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N1). +C +C XNORM (output) DOUBLE PRECISION +C The infinity-norm of the solution. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if TL and -ISGN*TR have almost reciprocal +C eigenvalues, so TL or TR is perturbed to get a +C nonsingular equation. +C +C NOTE: In the interests of speed, this routine does not +C check the inputs for errors. +C +C METHOD +C +C The equivalent linear algebraic system of equations is formed and +C solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 2000. +C This is a modification and slightly more efficient version of +C SLICOT Library routine SB03MU. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, Sylvester equation, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) +C .. +C .. Scalar Arguments .. + LOGICAL LTRANL, LTRANR + INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 + DOUBLE PRECISION SCALE, XNORM +C .. +C .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL BSWAP, XSWAP + INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K + DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, + $ TEMP, U11, U12, U22, XMAX +C .. +C .. Local Arrays .. + LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) + INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), + $ LOCU22( 4 ) + DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL DSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Data statements .. + DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , + $ LOCU22 / 4, 3, 2, 1 / + DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / + DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / +C .. +C .. Executable Statements .. +C +C Do not check the input parameters for errors. +C + INFO = 0 + SCALE = ONE +C +C Quick return if possible. +C + IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN + XNORM = ZERO + RETURN + END IF +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + SGN = ISGN +C + K = N1 + N1 + N2 - 2 + GO TO ( 10, 20, 30, 50 )K +C +C 1-by-1: TL11*X*TR11 + ISGN*X = B11. +C + 10 CONTINUE + TAU1 = TL( 1, 1 )*TR( 1, 1 ) + SGN + BET = ABS( TAU1 ) + IF( BET.LE.SMLNUM ) THEN + TAU1 = SMLNUM + BET = SMLNUM + INFO = 1 + END IF +C + GAM = ABS( B( 1, 1 ) ) + IF( SMLNUM*GAM.GT.BET ) + $ SCALE = ONE / GAM +C + X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 + XNORM = ABS( X( 1, 1 ) ) + RETURN +C +C 1-by-2: +C TL11*[X11 X12]*op[TR11 TR12] + ISGN*[X11 X12] = [B11 B12]. +C [TR21 TR22] +C + 20 CONTINUE +C + SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + $ *ABS( TL( 1, 1 ) )*EPS, + $ SMLNUM ) + TMP( 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN + TMP( 4 ) = TL( 1, 1 )*TR( 2, 2 ) + SGN + IF( LTRANR ) THEN + TMP( 2 ) = TL( 1, 1 )*TR( 2, 1 ) + TMP( 3 ) = TL( 1, 1 )*TR( 1, 2 ) + ELSE + TMP( 2 ) = TL( 1, 1 )*TR( 1, 2 ) + TMP( 3 ) = TL( 1, 1 )*TR( 2, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 1, 2 ) + GO TO 40 +C +C 2-by-1: +C op[TL11 TL12]*[X11]*TR11 + ISGN*[X11] = [B11]. +C [TL21 TL22] [X21] [X21] [B21] +C + 30 CONTINUE + SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) + $ *ABS( TR( 1, 1 ) )*EPS, + $ SMLNUM ) + TMP( 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN + TMP( 4 ) = TL( 2, 2 )*TR( 1, 1 ) + SGN + IF( LTRANL ) THEN + TMP( 2 ) = TL( 1, 2 )*TR( 1, 1 ) + TMP( 3 ) = TL( 2, 1 )*TR( 1, 1 ) + ELSE + TMP( 2 ) = TL( 2, 1 )*TR( 1, 1 ) + TMP( 3 ) = TL( 1, 2 )*TR( 1, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + 40 CONTINUE +C +C Solve 2-by-2 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + IPIV = IDAMAX( 4, TMP, 1 ) + U11 = TMP( IPIV ) + IF( ABS( U11 ).LE.SMIN ) THEN + INFO = 1 + U11 = SMIN + END IF + U12 = TMP( LOCU12( IPIV ) ) + L21 = TMP( LOCL21( IPIV ) ) / U11 + U22 = TMP( LOCU22( IPIV ) ) - U12*L21 + XSWAP = XSWPIV( IPIV ) + BSWAP = BSWPIV( IPIV ) + IF( ABS( U22 ).LE.SMIN ) THEN + INFO = 1 + U22 = SMIN + END IF + IF( BSWAP ) THEN + TEMP = BTMP( 2 ) + BTMP( 2 ) = BTMP( 1 ) - L21*TEMP + BTMP( 1 ) = TEMP + ELSE + BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) + END IF + IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. + $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN + SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + END IF + X2( 2 ) = BTMP( 2 ) / U22 + X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) + IF( XSWAP ) THEN + TEMP = X2( 2 ) + X2( 2 ) = X2( 1 ) + X2( 1 ) = TEMP + END IF + X( 1, 1 ) = X2( 1 ) + IF( N1.EQ.1 ) THEN + X( 1, 2 ) = X2( 2 ) + XNORM = ABS( X2( 1 ) ) + ABS( X2( 2 ) ) + ELSE + X( 2, 1 ) = X2( 2 ) + XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) ) + END IF + RETURN +C +C 2-by-2: +C op[TL11 TL12]*[X11 X12]*op[TR11 TR12] + ISGN*[X11 X12] = [B11 B12] +C [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] +C +C Solve equivalent 4-by-4 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + 50 CONTINUE + SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN + SMIN = MAX( EPS*SMIN, SMLNUM ) + T16( 1, 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN + T16( 2, 2 ) = TL( 2, 2 )*TR( 1, 1 ) + SGN + T16( 3, 3 ) = TL( 1, 1 )*TR( 2, 2 ) + SGN + T16( 4, 4 ) = TL( 2, 2 )*TR( 2, 2 ) + SGN + IF( LTRANL ) THEN + T16( 1, 2 ) = TL( 2, 1 )*TR( 1, 1 ) + T16( 2, 1 ) = TL( 1, 2 )*TR( 1, 1 ) + T16( 3, 4 ) = TL( 2, 1 )*TR( 2, 2 ) + T16( 4, 3 ) = TL( 1, 2 )*TR( 2, 2 ) + ELSE + T16( 1, 2 ) = TL( 1, 2 )*TR( 1, 1 ) + T16( 2, 1 ) = TL( 2, 1 )*TR( 1, 1 ) + T16( 3, 4 ) = TL( 1, 2 )*TR( 2, 2 ) + T16( 4, 3 ) = TL( 2, 1 )*TR( 2, 2 ) + END IF + IF( LTRANR ) THEN + T16( 1, 3 ) = TL( 1, 1 )*TR( 1, 2 ) + T16( 2, 4 ) = TL( 2, 2 )*TR( 1, 2 ) + T16( 3, 1 ) = TL( 1, 1 )*TR( 2, 1 ) + T16( 4, 2 ) = TL( 2, 2 )*TR( 2, 1 ) + ELSE + T16( 1, 3 ) = TL( 1, 1 )*TR( 2, 1 ) + T16( 2, 4 ) = TL( 2, 2 )*TR( 2, 1 ) + T16( 3, 1 ) = TL( 1, 1 )*TR( 1, 2 ) + T16( 4, 2 ) = TL( 2, 2 )*TR( 1, 2 ) + END IF + IF( LTRANL .AND. LTRANR ) THEN + T16( 1, 4 ) = TL( 2, 1 )*TR( 1, 2 ) + T16( 2, 3 ) = TL( 1, 2 )*TR( 1, 2 ) + T16( 3, 2 ) = TL( 2, 1 )*TR( 2, 1 ) + T16( 4, 1 ) = TL( 1, 2 )*TR( 2, 1 ) + ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN + T16( 1, 4 ) = TL( 2, 1 )*TR( 2, 1 ) + T16( 2, 3 ) = TL( 1, 2 )*TR( 2, 1 ) + T16( 3, 2 ) = TL( 2, 1 )*TR( 1, 2 ) + T16( 4, 1 ) = TL( 1, 2 )*TR( 1, 2 ) + ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN + T16( 1, 4 ) = TL( 1, 2 )*TR( 1, 2 ) + T16( 2, 3 ) = TL( 2, 1 )*TR( 1, 2 ) + T16( 3, 2 ) = TL( 1, 2 )*TR( 2, 1 ) + T16( 4, 1 ) = TL( 2, 1 )*TR( 2, 1 ) + ELSE + T16( 1, 4 ) = TL( 1, 2 )*TR( 2, 1 ) + T16( 2, 3 ) = TL( 2, 1 )*TR( 2, 1 ) + T16( 3, 2 ) = TL( 1, 2 )*TR( 1, 2 ) + T16( 4, 1 ) = TL( 2, 1 )*TR( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + BTMP( 3 ) = B( 1, 2 ) + BTMP( 4 ) = B( 2, 2 ) +C +C Perform elimination. +C + DO 100 I = 1, 3 + XMAX = ZERO +C + DO 70 IP = I, 4 +C + DO 60 JP = I, 4 + IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T16( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 60 CONTINUE +C + 70 CONTINUE +C + IF( IPSV.NE.I ) THEN + CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T16( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T16( I, I ) = SMIN + END IF +C + DO 90 J = I + 1, 4 + T16( J, I ) = T16( J, I ) / T16( I, I ) + BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) +C + DO 80 K = I + 1, 4 + T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) + 80 CONTINUE +C + 90 CONTINUE +C + 100 CONTINUE +C + IF( ABS( T16( 4, 4 ) ).LT.SMIN ) + $ T16( 4, 4 ) = SMIN + IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN + SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), + $ ABS( BTMP( 4 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + BTMP( 4 ) = BTMP( 4 )*SCALE + END IF +C + DO 120 I = 1, 4 + K = 5 - I + TEMP = ONE / T16( K, K ) + TMP( K ) = BTMP( K )*TEMP +C + DO 110 J = K + 1, 4 + TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) + 110 CONTINUE +C + 120 CONTINUE +C + DO 130 I = 1, 3 + IF( JPIV( 4-I ).NE.4-I ) THEN + TEMP = TMP( 4-I ) + TMP( 4-I ) = TMP( JPIV( 4-I ) ) + TMP( JPIV( 4-I ) ) = TEMP + END IF + 130 CONTINUE +C + X( 1, 1 ) = TMP( 1 ) + X( 2, 1 ) = TMP( 2 ) + X( 1, 2 ) = TMP( 3 ) + X( 2, 2 ) = TMP( 4 ) + XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 3 ) ), + $ ABS( TMP( 2 ) ) + ABS( TMP( 4 ) ) ) +C + RETURN +C *** Last line of SB04PX *** + END diff --git a/modules/cacsd/src/slicot/sb04px.lo b/modules/cacsd/src/slicot/sb04px.lo new file mode 100755 index 000000000..9716f0240 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04px.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04px.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04px.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04py.f b/modules/cacsd/src/slicot/sb04py.f new file mode 100755 index 000000000..923ed8af6 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04py.f @@ -0,0 +1,1095 @@ + SUBROUTINE SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, + $ LDC, SCALE, DWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To solve for X the discrete-time Sylvester equation +C +C op(A)*X*op(B) + ISGN*X = scale*C, +C +C where op(A) = A or A**T, A and B are both upper quasi-triangular, +C and ISGN = 1 or -1. A is M-by-M and B is N-by-N; the right hand +C side C and the solution X are M-by-N; and scale is an output scale +C factor, set less than or equal to 1 to avoid overflow in X. The +C solution matrix X is overwritten onto C. +C +C A and B must be in Schur canonical form (as returned by LAPACK +C Library routine DHSEQR), that is, block upper triangular with +C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has +C its diagonal elements equal and its off-diagonal elements of +C opposite sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C TRANB CHARACTER*1 +C Specifies the form of op(B) to be used, as follows: +C = 'N': op(B) = B (No transpose); +C = 'T': op(B) = B**T (Transpose); +C = 'C': op(B) = B**T (Conjugate transpose = Transpose). +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A, and the number of rows in the +C matrices X and C. M >= 0. +C +C N (input) INTEGER +C The order of the matrix B, and the number of columns in +C the matrices X and C. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain the +C upper quasi-triangular matrix A, in Schur canonical form. +C The part of A below the first sub-diagonal is not +C referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain the +C upper quasi-triangular matrix B, in Schur canonical form. +C The part of B below the first sub-diagonal is not +C referenced. +C +C LDB (input) INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the right hand side matrix C. +C On exit, if INFO >= 0, the leading M-by-N part of this +C array contains the solution matrix X. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: A and -ISGN*B have almost reciprocal eigenvalues; +C perturbed values were used to solve the equation +C (but the matrices A and B are unchanged). +C +C METHOD +C +C The solution matrix X is computed column-wise via a back +C substitution scheme, an extension and refinement of the algorithm +C in [1], similar to that used in [2] for continuous-time Sylvester +C equations. A set of equivalent linear algebraic systems of +C equations of order at most four are formed and solved using +C Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. +C D. Sima, University of Bucharest, April 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C Partly based on the routine SYLSV, A. Varga, 1992. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, matrix algebra, Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER INFO, ISGN, LDA, LDB, LDC, M, N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ) +C .. +C .. Local Scalars .. + LOGICAL NOTRNA, NOTRNB + INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, + $ MNK1, MNK2, MNL1, MNL2 + DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, + $ SCALOC, SGN, SMIN, SMLNUM, SUMR, XNORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLANGE + EXTERNAL DDOT, DLAMCH, DLANGE, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLABAD, DLALN2, DSCAL, SB04PX, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters +C + NOTRNA = LSAME( TRANA, 'N' ) + NOTRNB = LSAME( TRANB, 'N' ) +C + INFO = 0 + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. + $ .NOT.LSAME( TRANB, 'C' ) ) THEN + INFO = -2 + ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB04PY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + SCALE = ONE + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'Precision' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( M*N ) / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), + $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) ) +C + SGN = ISGN +C + IF( NOTRNA .AND. NOTRNB ) THEN +C +C Solve A*X*B + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C bottom-left corner column by column by +C +C A(K,K)*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C M +C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L) + +C J=K+1 +C M L-1 +C SUM { A(K,J) * SUM [X(J,I)*B(I,L)] }. +C J=K I=1 +C +C Start column loop (index = L) +C L1 (L2) : column index of the first (last) row of X(K,L). +C + LNEXT = 1 +C + DO 60 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 60 + L1 = L + IF( L.EQ.N ) THEN + L2 = L + ELSE + IF( B( L+1, L ).NE.ZERO ) THEN + L2 = L + 1 + ELSE + L2 = L + END IF + LNEXT = L2 + 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = M +C + DO 50 K = M, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 50 + K2 = K + IF( K.EQ.1 ) THEN + K1 = K + ELSE + IF( A( K, K-1 ).NE.ZERO ) THEN + K1 = K - 1 + ELSE + K1 = K + END IF + KNEXT = K1 - 1 + END IF +C + MNK1 = MIN( K1+1, M ) + MNK2 = MIN( K2+1, M ) + P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) + DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), + $ 1 ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN +C + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 10 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 20 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 20 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) + P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) +C + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L2, L1 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .FALSE., .FALSE., ISGN, 2, 2, + $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, + $ 2, SCALOC, X, 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 40 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 40 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 50 CONTINUE +C + 60 CONTINUE +C + ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN +C +C Solve A'*X*B + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C upper-left corner column by column by +C +C A(K,K)'*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C K-1 +C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L) + +C J=1 +C K L-1 +C SUM A(J,K)' * { SUM [X(J,I)*B(I,L)] }. +C J=1 I=1 +C +C Start column loop (index = L) +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = 1 +C + DO 120 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 120 + L1 = L + IF( L.EQ.N ) THEN + L2 = L + ELSE + IF( B( L+1, L ).NE.ZERO ) THEN + L2 = L + 1 + ELSE + L2 = L + END IF + LNEXT = L2 + 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = 1 +C + DO 110 K = 1, M + IF( K.LT.KNEXT ) + $ GO TO 110 + K1 = K + IF( K.EQ.M ) THEN + K2 = K + ELSE + IF( A( K+1, K ).NE.ZERO ) THEN + K2 = K + 1 + ELSE + K2 = K + END IF + KNEXT = K2 + 1 + END IF +C + P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1), + $ 1 ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN +C + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 70 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L1), 1 ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 80 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 80 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 90 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 90 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + CALL DSCAL( K1, SCALOC, DWORK( M+1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) +C + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L1), 1 ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 100 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + CALL DSCAL( K2, SCALOC, DWORK( M+1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 110 CONTINUE +C + 120 CONTINUE +C + ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN +C +C Solve A'*X*B' + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C top-right corner column by column by +C +C A(K,K)'*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C K-1 +C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L)' + +C J=1 +C K N +C SUM A(J,K)' * { SUM [X(J,I)*B(L,I)'] }. +C J=1 I=L+1 +C +C Start column loop (index = L) +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = N +C + DO 180 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 180 + L2 = L + IF( L.EQ.1 ) THEN + L1 = L + ELSE + IF( B( L, L-1 ).NE.ZERO ) THEN + L1 = L - 1 + ELSE + L1 = L + END IF + LNEXT = L1 - 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = 1 +C + DO 170 K = 1, M + IF( K.LT.KNEXT ) + $ GO TO 170 + K1 = K + IF( K.EQ.M ) THEN + K2 = K + ELSE + IF( A( K+1, K ).NE.ZERO ) THEN + K2 = K + 1 + ELSE + K2 = K + END IF + KNEXT = K2 + 1 + END IF +C + MNL1 = MIN( L1+1, N ) + MNL2 = MIN( L2+1, N ) + P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 130 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 130 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, + $ B( L1, MNL1 ), LDB ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 140 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 140 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 150 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 150 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + CALL DSCAL( K1, SCALOC, DWORK(M+1), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) +C + DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 160 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 160 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + CALL DSCAL( K2, SCALOC, DWORK(M+1), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 170 CONTINUE +C + 180 CONTINUE +C + ELSE +C +C Solve A*X*B' + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C bottom-right corner column by column by +C +C A(K,K)*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C M +C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L)' + +C J=K+1 +C M N +C SUM { A(K,J) * SUM [X(J,I)*B(L,I)'] }. +C J=K I=L+1 +C +C Start column loop (index = L) +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = N +C + DO 240 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 240 + L2 = L + IF( L.EQ.1 ) THEN + L1 = L + ELSE + IF( B( L, L-1 ).NE.ZERO ) THEN + L1 = L - 1 + ELSE + L1 = L + END IF + LNEXT = L1 - 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = M +C + DO 230 K = M, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 230 + K2 = K + IF( K.EQ.1 ) THEN + K1 = K + ELSE + IF( A( K, K-1 ).NE.ZERO ) THEN + K1 = K - 1 + ELSE + K1 = K + END IF + KNEXT = K1 - 1 + END IF +C + MNK1 = MIN( K1+1, M ) + MNK2 = MIN( K2+1, M ) + MNL1 = MIN( L1+1, N ) + MNL2 = MIN( L2+1, N ) + P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) + DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN +C + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 190 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 190 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, + $ B( L1, MNL1 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 200 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 200 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 210 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 210 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) + P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) +C + DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 220 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 220 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 230 CONTINUE +C + 240 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04PY *** + END diff --git a/modules/cacsd/src/slicot/sb04py.lo b/modules/cacsd/src/slicot/sb04py.lo new file mode 100755 index 000000000..ebfecf9c1 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04py.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04py.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04py.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04qd.f b/modules/cacsd/src/slicot/sb04qd.f new file mode 100755 index 000000000..18e2c8c2d --- /dev/null +++ b/modules/cacsd/src/slicot/sb04qd.f @@ -0,0 +1,360 @@ + SUBROUTINE SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, + $ DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To solve for X the discrete-time Sylvester equation +C +C X + AXB = C, +C +C where A, B, C and X are general N-by-N, M-by-M, N-by-M and +C N-by-M matrices respectively. A Hessenberg-Schur method, which +C reduces A to upper Hessenberg form, H = U'AU, and B' to real +C Schur form, S = Z'B'Z (with U, Z orthogonal matrices), is used. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A of the equation. +C On exit, the leading N-by-N upper Hessenberg part of this +C array contains the matrix H, and the remainder of the +C leading N-by-N part, together with the elements 2,3,...,N +C of array DWORK, contain the orthogonal transformation +C matrix U (stored in factored form). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix B of the equation. +C On exit, the leading M-by-M part of this array contains +C the quasi-triangular Schur factor S of the matrix B'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading N-by-M part of this array contains +C the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) +C The leading M-by-M part of this array contains the +C orthogonal matrix Z used to transform B' to real upper +C Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,M). +C +C Workspace +C +C IWORK INTEGER array, dimension (4*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain +C the scalar factors of the elementary reflectors used to +C reduce A to upper Hessenberg form, as returned by LAPACK +C Library routine DGEHRD. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = MAX(1, 2*N*N + 9*N, 5*M, N + M). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to +C compute all the eigenvalues of B (see LAPACK Library +C routine DGEES); +C > M: if a singular matrix was encountered whilst solving +C for the (INFO-M)-th column of matrix X. +C +C METHOD +C +C The matrix A is transformed to upper Hessenberg form H = U'AU by +C the orthogonal transformation matrix U; matrix B' is transformed +C to real upper Schur form S = Z'B'Z using the orthogonal +C transformation matrix Z. The matrix C is also multiplied by the +C transformations, F = U'CZ, and the solution matrix Y of the +C transformed system +C +C Y + HYS' = F +C +C is computed by back substitution. Finally, the matrix Y is then +C multiplied by the orthogonal transformation matrices, X = UYZ', in +C order to obtain the solution matrix X to the original problem. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C 3 3 2 2 +C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N +C operations and is backward stable. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000, Aug. 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER BL, CHUNK, I, IEIG, IFAIL, IHI, ILO, IND, ITAU, + $ JWORK, SDIM, WRKOPT +C .. Local Scalars .. + LOGICAL BLAS3, BLOCK +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, + $ DORMHR, DSWAP, SB04QU, SB04QY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 9*N, 5*M, N + M ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ILO = 1 + IHI = N + WRKOPT = 2*N*N + 9*N +C +C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper +C triangular. That is, H = U' * A * U (store U in factored +C form) and S = Z' * B' * Z (save Z). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 20 I = 2, M + CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) + 20 CONTINUE +C +C Workspace: need 5*M; +C prefer larger. +C + IEIG = M + 1 + JWORK = IEIG + M + CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, + $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), + $ LDWORK-JWORK+1, BWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need 2*N; +C prefer N + N*NB. +C + ITAU = 2 + JWORK = ITAU + N - 1 + CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, MAX( INT( DWORK(JWORK) ), N*M )+JWORK-1 ) +C + CHUNK = ( LDWORK - JWORK + 1 ) / M + BLOCK = MIN( CHUNK, N ).GT.1 + BLAS3 = CHUNK.GE.N .AND. BLOCK +C + IF ( BLAS3 ) THEN + CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, + $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many rows of C as possible. +C + DO 40 I = 1, N, CHUNK + BL = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, ONE, + $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) + CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) + 40 CONTINUE +C + ELSE +C + DO 60 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 60 CONTINUE +C + END IF +C +C Step 3 : Solve Y + H * Y * S' = F for Y. +C + IND = M + 80 CONTINUE +C + IF ( IND.GT.1 ) THEN + IF ( B(IND,IND-1).EQ.ZERO ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N. +C + CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + IND = IND - 1 + ELSE +C +C Solve a special linear algebraic system of order 2*N. +C Workspace: 2*N*N + 9*N; +C + CALL SB04QU( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + IND = IND - 2 + END IF + GO TO 80 + ELSE IF ( IND.EQ.1 ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N; +C + CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + END IF +C +C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( BLAS3 ) THEN + CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, + $ Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many rows of C as possible. +C + DO 100 I = 1, N, CHUNK + BL = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'NoTranspose', 'Transpose', BL, M, M, ONE, + $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) + CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) + 100 CONTINUE +C + ELSE +C + DO 120 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 120 CONTINUE + END IF +C + RETURN +C *** Last line of SB04QD *** + END diff --git a/modules/cacsd/src/slicot/sb04qd.lo b/modules/cacsd/src/slicot/sb04qd.lo new file mode 100755 index 000000000..bc8f45fe8 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04qd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04qd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04qd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04qr.f b/modules/cacsd/src/slicot/sb04qr.f new file mode 100755 index 000000000..7c837c1a6 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04qr.f @@ -0,0 +1,208 @@ + SUBROUTINE SB04QR( M, D, IPR, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix has zeros below the third subdiagonal and zero elements on +C the third subdiagonal with even column indices. The matrix is +C stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0, M even. +C Note that parameter M should have twice the value in the +C original problem (see SLICOT Library routine SB04QU). +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*M/2+4*M) +C On entry, the first M*M/2 + 3*M elements of this array +C must contain the coefficient matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04QU. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, + $ MPI2 + DOUBLE PRECISION D1, D2, D3, DMAX +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS, MOD +C .. Executable Statements .. +C + INFO = 0 + I2 = M*M/2 + 3*M + MPI = M + IPRM = I2 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GE.4 .AND. MOD( I, 2 ).EQ.0 ) M1 = M1 - 2 + 20 CONTINUE +C + M1 = M - 1 + MPI1 = M + 1 +C +C Reduce to upper triangular form. +C + DO 80 I = 1, M1 + MPI = MPI1 + MPI1 = MPI1 + 1 + IPRM = IPR(MPI) + D1 = D(IPRM) + I1 = 3 + IF ( MOD( I, 2 ).EQ.0 ) I1 = 2 + IF ( I.EQ.M1 ) I1 = 1 + MPI2 = MPI + I1 + L = 0 + DMAX = ABS( D1 ) +C + DO 40 J = MPI1, MPI2 + D2 = D(IPR(J)) + D3 = ABS( D2 ) + IF ( D3.GT.DMAX ) THEN + DMAX = D3 + D1 = D2 + L = J - MPI + END IF + 40 CONTINUE +C +C Check singularity. +C + IF ( DMAX.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + IF ( L.GT.0 ) THEN +C +C Permute the row indices. +C + K = IPRM + J = MPI + L + IPRM = IPR(J) + IPR(J) = K + IPR(MPI) = IPRM + K = IPR(I) + I2 = I + L + IPR(I) = IPR(I2) + IPR(I2) = K + END IF + IPRM = IPRM + 1 +C +C Annihilate the subdiagonal elements of the matrix. +C + I2 = I + D3 = D(IPR(I)) +C + DO 60 J = MPI1, MPI2 + I2 = I2 + 1 + IPRM1 = IPR(J) + DMAX = -D(IPRM1)/D1 + D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 + CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) + IPR(J) = IPR(J) + 1 + 60 CONTINUE +C + 80 CONTINUE +C + MPI = M + M + IPRM = IPR(MPI) +C +C Check singularity. +C + IF ( D(IPRM).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPRM) +C + DO 120 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + DMAX = ZERO +C + DO 100 K = I+1, M + IPRM1 = IPRM1 + 1 + DMAX = DMAX + D(IPR(K))*D(IPRM1) + 100 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) + 120 CONTINUE +C + RETURN +C *** Last line of SB04QR *** + END diff --git a/modules/cacsd/src/slicot/sb04qr.lo b/modules/cacsd/src/slicot/sb04qr.lo new file mode 100755 index 000000000..3a6e13e3c --- /dev/null +++ b/modules/cacsd/src/slicot/sb04qr.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04qr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04qr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04qu.f b/modules/cacsd/src/slicot/sb04qu.f new file mode 100755 index 000000000..0335f1578 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04qu.f @@ -0,0 +1,202 @@ + SUBROUTINE SB04QU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order 2*M +C whose coefficient matrix has zeros below the third subdiagonal, +C and zero elements on the third subdiagonal with even column +C indices. Such systems appear when solving discrete-time Sylvester +C equations using the Hessenberg-Schur method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C IND and IND - 1 specify the indices of the columns in C +C to be computed. IND > 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with columns IND-1 and IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (2*M*M+8*M) +C +C IPR INTEGER array, dimension (4*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order 2*M, whose coefficient +C matrix has zeros below the third subdiagonal and zero elements on +C the third subdiagonal with even column indices, is constructed and +C solved. The coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, IND1, J, K, K1, K2, M2 + DOUBLE PRECISION TEMP +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DTRMV, SB04QR +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + IND1 = IND - 1 +C + IF ( IND.LT.N ) THEN + DUM(1) = ZERO + CALL DCOPY ( M, DUM, 0, D, 1 ) + DO 10 I = IND + 1, N + CALL DAXPY ( M, B(IND1,I), C(1,I), 1, D, 1 ) + 10 CONTINUE +C + DO 20 I = 2, M + C(I,IND1) = C(I,IND1) - A(I,I-1)*D(I-1) + 20 CONTINUE + CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, + $ D, 1 ) + DO 30 I = 1, M + C(I,IND1) = C(I,IND1) - D(I) + 30 CONTINUE +C + CALL DCOPY ( M, DUM, 0, D, 1 ) + DO 40 I = IND + 1, N + CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) + 40 CONTINUE +C + DO 50 I = 2, M + C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) + 50 CONTINUE + CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, + $ D, 1 ) + DO 60 I = 1, M + C(I,IND) = C(I,IND) - D(I) + 60 CONTINUE + END IF +C +C Construct the linear algebraic system of order 2*M. +C + K1 = -1 + M2 = 2*M + I2 = M2*(M + 3) + K = M2 +C + DO 80 I = 1, M +C + DO 70 J = MAX( 1, I - 1 ), M + K1 = K1 + 2 + K2 = K1 + K + TEMP = A(I,J) + D(K1) = TEMP * B(IND1,IND1) + D(K1+1) = TEMP * B(IND1,IND) + D(K2) = TEMP * B(IND,IND1) + D(K2+1) = TEMP * B(IND,IND) + IF ( I.EQ.J ) THEN + D(K1) = D(K1) + ONE + D(K2+1) = D(K2+1) + ONE + END IF + 70 CONTINUE +C + K1 = K2 + IF ( I.GT.1 ) K = K - 2 +C +C Store the right hand side. +C + I2 = I2 + 2 + D(I2) = C(I,IND) + D(I2-1) = C(I,IND1) + 80 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04QR( M2, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE + I2 = 0 +C + DO 90 I = 1, M + I2 = I2 + 2 + C(I,IND1) = D(IPR(I2-1)) + C(I,IND) = D(IPR(I2)) + 90 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04QU *** + END diff --git a/modules/cacsd/src/slicot/sb04qu.lo b/modules/cacsd/src/slicot/sb04qu.lo new file mode 100755 index 000000000..59c34e2ef --- /dev/null +++ b/modules/cacsd/src/slicot/sb04qu.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04qu.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04qu.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04qy.f b/modules/cacsd/src/slicot/sb04qy.f new file mode 100755 index 000000000..95204cf9b --- /dev/null +++ b/modules/cacsd/src/slicot/sb04qy.f @@ -0,0 +1,169 @@ + SUBROUTINE SB04QY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order M whose +C coefficient matrix is in upper Hessenberg form. Such systems +C appear when solving discrete-time Sylvester equations using the +C Hessenberg-Schur method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C The index of the column in C to be computed. IND >= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with column IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) +C +C IPR INTEGER array, dimension (2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order M, with coefficient +C matrix in upper Hessenberg form is constructed and solved. The +C coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, J, K, K1, K2, M1 +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, DTRMV, SB04MW +C .. Executable Statements .. +C + IF ( IND.LT.N ) THEN + DUM(1) = ZERO + CALL DCOPY ( M, DUM, 0, D, 1 ) + DO 10 I = IND + 1, N + CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) + 10 CONTINUE + DO 20 I = 2, M + C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) + 20 CONTINUE + CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, + $ D, 1 ) + DO 30 I = 1, M + C(I,IND) = C(I,IND) - D(I) + 30 CONTINUE + END IF +C + M1 = M + 1 + I2 = ( M*M1 )/2 + M1 + K2 = 1 + K = M +C +C Construct the linear algebraic system of order M. +C + DO 40 I = 1, M + J = M1 - K + CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) + CALL DSCAL ( K, B(IND,IND), D(K2), 1 ) + K1 = K2 + K2 = K2 + K + IF ( I.GT.1 ) THEN + K1 = K1 + 1 + K = K - 1 + END IF + D(K1) = D(K1) + ONE +C +C Store the right hand side. +C + D(I2) = C(I,IND) + I2 = I2 + 1 + 40 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MW( M, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE +C + DO 50 I = 1, M + C(I,IND) = D(IPR(I)) + 50 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04QY *** + END diff --git a/modules/cacsd/src/slicot/sb04qy.lo b/modules/cacsd/src/slicot/sb04qy.lo new file mode 100755 index 000000000..78b94b760 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04qy.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04qy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04qy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04rd.f b/modules/cacsd/src/slicot/sb04rd.f new file mode 100755 index 000000000..fa072c6d6 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04rd.f @@ -0,0 +1,390 @@ + SUBROUTINE SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, + $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To solve for X the discrete-time Sylvester equation +C +C X + AXB = C, +C +C with at least one of the matrices A or B in Schur form and the +C other in Hessenberg or Schur form (both either upper or lower); +C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, +C respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHU CHARACTER*1 +C Indicates whether A and/or B is/are in Schur or +C Hessenberg form as follows: +C = 'A': A is in Schur form, B is in Hessenberg form; +C = 'B': B is in Schur form, A is in Hessenberg form; +C = 'S': Both A and B are in Schur form. +C +C ULA CHARACTER*1 +C Indicates whether A is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and +C upper Schur form otherwise; +C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and +C lower Schur form otherwise. +C +C ULB CHARACTER*1 +C Indicates whether B is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and +C upper Schur form otherwise; +C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and +C lower Schur form otherwise. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C coefficient matrix A of the equation. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading M-by-M part of this array must contain the +C coefficient matrix B of the equation. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, if INFO = 0, the leading N-by-M part of this +C array contains the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity in +C the Sylvester equation. If the user sets TOL > 0, then the +C given value of TOL is used as a lower bound for the +C reciprocal condition number; a matrix whose estimated +C condition number is less than 1/TOL is considered to be +C nonsingular. If the user sets TOL <= 0, then a default +C tolerance, defined by TOLDEF = EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*MAX(M,N)) +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = 2*N, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; +C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if a (numerically) singular matrix T was encountered +C during the computation of the solution matrix X. +C That is, the estimated reciprocal condition number +C of T is less than or equal to TOL. +C +C METHOD +C +C Matrices A and B are assumed to be in (upper or lower) Hessenberg +C or Schur form (with at least one of them in Schur form). The +C solution matrix X is then computed by rows or columns via the back +C substitution scheme proposed by Golub, Nash and Van Loan (see +C [1]), which involves the solution of triangular systems of +C equations that are constructed recursively and which may be nearly +C singular if A and -B have almost reciprocal eigenvalues. If near +C singularity is detected, then the routine returns with the Error +C Indicator (INFO) set to 1. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C 2 2 +C The algorithm requires approximately 5M N + 0.5MN operations in +C 2 2 +C the worst case and 2.5M N + 0.5MN operations in the best case +C (where M is the order of the matrix in Hessenberg form and N is +C the order of the matrix in Schur form) and is mixed stable (see +C [1]). +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHU, ULA, ULB + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) +C .. Local Scalars .. + CHARACTER ABSCHR + LOGICAL LABSCB, LABSCS, LULA, LULB + INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, + $ LDW, MAXMN + DOUBLE PRECISION SCALE, TOL1 +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, SB04PY, SB04RV, SB04RW, SB04RX, SB04RY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + MAXMN = MAX( M, N ) + LABSCB = LSAME( ABSCHU, 'B' ) + LABSCS = LSAME( ABSCHU, 'S' ) + LULA = LSAME( ULA, 'U' ) + LULB = LSAME( ULB, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. + $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.2*N .OR. + $ ( LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) .AND. + $ .NOT.( LABSCS .AND. LULA .AND. LULB ) ) ) THEN + INFO = -15 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAXMN.EQ.0 ) + $ RETURN +C + IF ( LABSCS .AND. LULA .AND. LULB ) THEN +C +C If both matrices are in a real Schur form, use SB04PY. +C + CALL SB04PY( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, + $ B, LDB, C, LDC, SCALE, DWORK, INFO ) + IF ( SCALE.NE.ONE ) + $ INFO = 1 + RETURN + END IF +C + LDW = 2*MAXMN + JWORK = LDW*LDW + 3*LDW + 1 + TOL1 = TOL + IF ( TOL1.LE.ZERO ) + $ TOL1 = DLAMCH( 'Epsilon' ) +C +C Choose the smallest of both matrices as the one in Hessenberg +C form when possible. +C + ABSCHR = ABSCHU + IF ( LABSCS ) THEN + IF ( N.GT.M ) THEN + ABSCHR = 'A' + ELSE + ABSCHR = 'B' + END IF + END IF + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C B is in Schur form: recursion on the columns of B. +C + IF ( LULB ) THEN +C +C B is upper: forward recursion. +C + IBEG = 1 + IEND = M + FWD = 1 + INCR = 0 + ELSE +C +C B is lower: backward recursion. +C + IBEG = M + IEND = 1 + FWD = -1 + INCR = -1 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( B(I+FWD,I).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04RW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, + $ A, LDA, DWORK(JWORK), DWORK ) + CALL SB04RY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) + ELSE + IPINCR = I + INCR + CALL SB04RV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, + $ A, LDA, DWORK(JWORK), DWORK ) + CALL SB04RX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), + $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), + $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) + CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) + END IF + I = I + FWD*ISTEP + GO TO 20 + END IF +C END WHILE 20 + ELSE +C +C A is in Schur form: recursion on the rows of A. +C + IF ( LULA ) THEN +C +C A is upper: backward recursion. +C + IBEG = N + IEND = 1 + FWD = -1 + INCR = -1 + ELSE +C +C A is lower: forward recursion. +C + IBEG = 1 + IEND = N + FWD = 1 + INCR = 0 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( A(I,I+FWD).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04RW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, + $ B, LDB, DWORK(JWORK), DWORK ) + CALL SB04RY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + ELSE + IPINCR = I + INCR + CALL SB04RV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, + $ B, LDB, DWORK(JWORK), DWORK ) + CALL SB04RX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), + $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), + $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) + CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) + END IF + I = I + FWD*ISTEP + GO TO 40 + END IF +C END WHILE 40 + END IF +C + RETURN +C *** Last line of SB04RD *** + END diff --git a/modules/cacsd/src/slicot/sb04rd.lo b/modules/cacsd/src/slicot/sb04rd.lo new file mode 100755 index 000000000..f956c80a4 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04rd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04rd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04rd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04rv.f b/modules/cacsd/src/slicot/sb04rv.f new file mode 100755 index 000000000..a6445f89b --- /dev/null +++ b/modules/cacsd/src/slicot/sb04rv.f @@ -0,0 +1,182 @@ + SUBROUTINE SB04RV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, + $ LDBA, D, DWORK ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To construct the right-hand sides D for a system of equations in +C quasi-Hessenberg form solved via SB04RX (case with 2 right-hand +C sides). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation X + AXB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the first column/row of C to be used in +C the construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C, the matrix not contained in AB. +C +C LDBA INTEGER +C The leading dimension of array BA. +C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading 2*N or 2*M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side stored as a matrix with two rows. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C where LDWORK is equal to 2*N or 2*M (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively). +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDBA, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the 2 columns of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) + CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, + $ ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX+1), + $ 1, ZERO, DWORK(N+1), 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, + $ ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.LT.M-1 ) THEN + CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX+1), 1, ZERO, DWORK(N+1), 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, + $ ONE, D(2), 2 ) + END IF + END IF + ELSE +C +C Construct the 2 rows of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) + CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N-1 ) THEN + CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, + $ AB(INDX,INDX+2), LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, + $ AB(INDX+1,INDX+2), LDAB, ZERO, DWORK(M+1), + $ 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, + $ ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), + $ LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX+1,1), + $ LDAB, ZERO, DWORK(M+1), 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, + $ ONE, D(2), 2 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04RV *** + END diff --git a/modules/cacsd/src/slicot/sb04rv.lo b/modules/cacsd/src/slicot/sb04rv.lo new file mode 100755 index 000000000..987580ba7 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04rv.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04rv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04rv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04rw.f b/modules/cacsd/src/slicot/sb04rw.f new file mode 100755 index 000000000..e62b0bd05 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04rw.f @@ -0,0 +1,162 @@ + SUBROUTINE SB04RW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, + $ LDBA, D, DWORK ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To construct the right-hand side D for a system of equations in +C Hessenberg form solved via SB04RY (case with 1 right-hand side). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation X + AXB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the column/row of C to be used in the +C construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C, the matrix not contained in AB. +C +C LDBA INTEGER +C The leading dimension of array BA. +C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading N or M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C where LDWORK is equal to N or M (depending on ABSCHR = 'B' +C or ABSCHR = 'A', respectively). +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDBA, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the column of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, + $ ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, + $ ONE, D, 1 ) + END IF + ELSE + IF ( INDX.LT.M ) THEN + CALL DGEMV( 'N', N, M-INDX, ONE, C(1,INDX+1), LDC, + $ AB(INDX+1,INDX), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, D, + $ 1 ) + END IF + END IF + ELSE +C +C Construct the row of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N ) THEN + CALL DGEMV( 'T', N-INDX, M, ONE, C(INDX+1,1), LDC, + $ AB(INDX,INDX+1), LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, + $ 1 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), + $ LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, + $ 1 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04RW *** + END diff --git a/modules/cacsd/src/slicot/sb04rw.lo b/modules/cacsd/src/slicot/sb04rw.lo new file mode 100755 index 000000000..2a121c305 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04rw.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04rw.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04rw.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04rx.f b/modules/cacsd/src/slicot/sb04rx.f new file mode 100755 index 000000000..afb78bd53 --- /dev/null +++ b/modules/cacsd/src/slicot/sb04rx.f @@ -0,0 +1,359 @@ + SUBROUTINE SB04RX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, + $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To solve a system of equations in quasi-Hessenberg form +C (Hessenberg form plus two consecutive offdiagonals) with two +C right-hand sides. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether A is upper or lower Hessenberg matrix, +C as follows: +C = 'U': A is upper Hessenberg; +C = 'L': A is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBD1, (input) DOUBLE PRECISION +C LAMBD2, These variables must contain the 2-by-2 block to be +C LAMBD3, multiplied to the elements of A. +C LAMBD4 +C +C D (input/output) DOUBLE PRECISION array, dimension (2*M) +C On entry, this array must contain the two right-hand +C side vectors of the quasi-Hessenberg system, stored +C row-wise. +C On exit, if INFO = 0, this array contains the two solution +C vectors of the quasi-Hessenberg system, stored row-wise. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the quasi-Hessenberg matrix. +C A matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) +C The leading 2*M-by-2*M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the quasi-Hessenberg matrix. The remaining 6*M elements +C are used as workspace for the computation of the +C reciprocal condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. +C LDDWOR >= MAX(1,2*M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the quasi-Hessenberg matrix is (numerically) +C singular. That is, its estimated reciprocal +C condition number is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M, LDA, and LDDWOR must be such that the value +C of the LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, 2*M ) ) +C +C These conditions are not checked by the routine. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, J2, M2, MJ, ML + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DLASET, DROT, DSCAL, DTRCON, + $ DTRSV +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + M2 = M*2 + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + J2 = J*2 + ML = MIN( M, J + 1 ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) + CALL DSCAL( ML, LAMBD1, DWORK(1,J2-1), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2-1), 2 ) + CALL DSCAL( ML, LAMBD3, DWORK(2,J2-1), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2), 2 ) + CALL DSCAL( ML, LAMBD2, DWORK(1,J2), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) + CALL DSCAL( ML, LAMBD4, DWORK(2,J2), 2 ) +C + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE + DWORK(J2,J2) = DWORK(J2,J2) + ONE + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(J+3,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J+2,J), DWORK(J+3,J), C, S, R ) + DWORK(J+2,J) = R + DWORK(J+3,J) = ZERO + CALL DROT( MJ, DWORK(J+2,J+1), LDDWOR, + $ DWORK(J+3,J+1), LDDWOR, C, S ) + CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J+2,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) + DWORK(J+1,J) = R + DWORK(J+2,J) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, + $ DWORK(J+2,J+1), LDDWOR, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(MJ+1,MJ-2).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ-1), DWORK(MJ+1,MJ-2), C, + $ S, R ) + DWORK(MJ+1,MJ-1) = R + DWORK(MJ+1,MJ-2) = ZERO + CALL DROT( MJ, DWORK(1,MJ-1), 1, DWORK(1,MJ-2), 1, + $ C, S ) + CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, + $ S, R ) + DWORK(MJ+1,MJ) = R + DWORK(MJ+1,MJ-1) = ZERO + CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, + $ S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J2 = J*2 + J1 = MAX( J - 1, 1 ) + ML = MIN( M - J + 2, M ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) + CALL DSCAL( ML, LAMBD1, DWORK(J1*2-1,J2-1), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2-1), 2 ) + CALL DSCAL( ML, LAMBD3, DWORK(J1*2,J2-1), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2), 2 ) + CALL DSCAL( ML, LAMBD2, DWORK(J1*2-1,J2), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) + CALL DSCAL( ML, LAMBD4, DWORK(J1*2,J2), 2 ) +C + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE + DWORK(J2,J2) = DWORK(J2,J2) + ONE + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(MJ-2,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ-1,MJ+1), DWORK(MJ-2,MJ+1), C, + $ S, R ) + DWORK(MJ-1,MJ+1) = R + DWORK(MJ-2,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ-1,1), LDDWOR, + $ DWORK(MJ-2,1), LDDWOR, C, S ) + CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, + $ S, R ) + DWORK(MJ,MJ+1) = R + DWORK(MJ-1,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(J,J+3).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J+2), DWORK(J,J+3), C, S, R ) + DWORK(J,J+2) = R + DWORK(J,J+3) = ZERO + CALL DROT( MJ, DWORK(J+1,J+2), 1, DWORK(J+1,J+3), + $ 1, C, S ) + CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J,J+2).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) + DWORK(J,J+1) = R + DWORK(J,J+2) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), + $ 1, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, + $ DWORK(1,M2+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04RX *** + END diff --git a/modules/cacsd/src/slicot/sb04rx.lo b/modules/cacsd/src/slicot/sb04rx.lo new file mode 100755 index 000000000..310d51aaf --- /dev/null +++ b/modules/cacsd/src/slicot/sb04rx.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04rx.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04rx.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb04ry.f b/modules/cacsd/src/slicot/sb04ry.f new file mode 100755 index 000000000..5981f510b --- /dev/null +++ b/modules/cacsd/src/slicot/sb04ry.f @@ -0,0 +1,245 @@ + SUBROUTINE SB04RY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, + $ DWORK, LDDWOR, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 2000. +C +C PURPOSE +C +C To solve a system of equations in Hessenberg form with one +C right-hand side. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether A is upper or lower Hessenberg matrix, +C as follows: +C = 'U': A is upper Hessenberg; +C = 'L': A is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBDA (input) DOUBLE PRECISION +C This variable must contain the value to be multiplied with +C the elements of A. +C +C D (input/output) DOUBLE PRECISION array, dimension (M) +C On entry, this array must contain the right-hand side +C vector of the Hessenberg system. +C On exit, if INFO = 0, this array contains the solution +C vector of the Hessenberg system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the Hessenberg matrix. A matrix +C whose estimated condition number is less than 1/TOL is +C considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) +C The leading M-by-M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the Hessenberg matrix. The remaining 3*M elements are +C used as workspace for the computation of the reciprocal +C condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Hessenberg matrix is (numerically) singular. +C That is, its estimated reciprocal condition number +C is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M, LDA, and LDDWOR must be such that the value +C of the LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, M ) ) +C +C These conditions are not checked by the routine. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBDA, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, MJ + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DROT, DSCAL, DTRCON, DTRSV +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) + CALL DSCAL( MIN( J+1, M ), LAMBDA, DWORK(1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + ONE + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J1 = MAX( J - 1, 1 ) + CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) + CALL DSCAL( M-J1+1, LAMBDA, DWORK(J1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + ONE + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, + $ DWORK(1,M+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04RY *** + END diff --git a/modules/cacsd/src/slicot/sb04ry.lo b/modules/cacsd/src/slicot/sb04ry.lo new file mode 100755 index 000000000..5130de3ab --- /dev/null +++ b/modules/cacsd/src/slicot/sb04ry.lo @@ -0,0 +1,12 @@ +# src/slicot/sb04ry.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb04ry.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb10dd.f b/modules/cacsd/src/slicot/sb10dd.f new file mode 100755 index 000000000..55894e4a2 --- /dev/null +++ b/modules/cacsd/src/slicot/sb10dd.f @@ -0,0 +1,991 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To compute the matrices of an H-infinity (sub)optimal n-state +C controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C for the discrete-time system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C j*Theta +C (A3) | A-e *I B2 | has full column rank for all +C | C1 D12 | +C +C 0 <= Theta < 2*Pi , +C +C j*Theta +C (A4) | A-e *I B1 | has full row rank for all +C | C2 D21 | +C +C 0 <= Theta < 2*Pi . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA > 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the matrix +C Z, solution of the Z-Riccati equation. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= max(1,N). +C +C RCOND (output) DOUBLE PRECISION array, dimension (8) +C RCOND contains estimates of the reciprocal condition +C numbers of the matrices which are to be inverted and +C estimates of the reciprocal condition numbers of the +C Riccati equations which have to be solved during the +C computation of the controller. (See the description of +C the algorithm in [2].) +C RCOND(1) contains the reciprocal condition number of the +C matrix R3; +C RCOND(2) contains the reciprocal condition number of the +C matrix R1 - R2'*inv(R3)*R2; +C RCOND(3) contains the reciprocal condition number of the +C matrix V21; +C RCOND(4) contains the reciprocal condition number of the +C matrix St3; +C RCOND(5) contains the reciprocal condition number of the +C matrix V12; +C RCOND(6) contains the reciprocal condition number of the +C matrix Im2 + DKHAT*D22 +C RCOND(7) contains the reciprocal condition number of the +C X-Riccati equation; +C RCOND(8) contains the reciprocal condition number of the +C Z-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used in neglecting the small singular values +C in rank determination. If TOL <= 0, then a default value +C equal to 1000*EPS is used, where EPS is the relative +C machine precision. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*max(M2,N),M,M2+NP2,N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(LW1,LW2,LW3,LW4), where +C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)); +C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)); +C LW3 = 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + 6*N + +C max(14*N+23,16*N,2*N+M,3*M); +C LW4 = 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + 6*N + +C N*(M+NP2) + max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C max((N+Q)*(N+Q+6),13*N*N + M*M + 2*Q*Q + N*(M+Q) + +C max(M*(M+7*N),2*Q*(8*N+M+2*Q)) + 6*N + +C max(14*N+23,16*N,2*N+max(M,2*Q),3*max(M,2*Q)). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C j*Theta +C = 1: if the matrix | A-e *I B2 | had not full +C | C1 D12 | +C column rank; +C j*Theta +C = 2: if the matrix | A-e *I B1 | had not full +C | C2 D21 | +C row rank; +C = 3: if the matrix D12 had not full column rank; +C = 4: if the matrix D21 had not full row rank; +C = 5: if the controller is not admissible (too small value +C of gamma); +C = 6: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 7: if the Z-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 8: if the matrix Im2 + DKHAT*D22 is singular. +C = 9: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C +C METHOD +C +C The routine implements the method presented in [1]. +C +C REFERENCES +C +C [1] Green, M. and Limebeer, D.J.N. +C Linear Robust Control. +C Prentice-Hall, Englewood Cliffs, NJ, 1995. +C +C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of linear +C discrete-time control systems. +C Report 99-8, Department of Engineering, Leicester University, +C April 1999. +C +C NUMERICAL ASPECTS +C +C With approaching the minimum value of gamma some of the matrices +C which are to be inverted tend to become ill-conditioned and +C the X- or Z-Riccati equation may also become ill-conditioned +C which may deteriorate the accuracy of the result. (The +C corresponding reciprocal condition numbers are given in +C the output array RCOND.) +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, discrete-time H-infinity optimal +C control, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, THOUSN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ THOUSN = 1.0D+3 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, LDX, LDZ, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA, TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( * ), X( LDX, * ), Z( LDZ, * ) + LOGICAL BWORK( * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IR2, IR3, IS2, IS3, IWB, IWC, IWD, IWG, + $ IWH, IWI, IWL, IWQ, IWR, IWRK, IWS, IWT, IWU, + $ IWV, IWW, J, LWAMAX, M1, M2, MINWRK, NP1, NP2 + DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL +C +C .. External Functions + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGESVD, DGETRF, DGETRS, DLACPY, + $ DLASET, DPOCON, DPOTRF, DSCAL, DSWAP, DSYRK, + $ DSYTRF, DSYTRS, DTRCON, DTRSM, MA02AD, MB01RU, + $ MB01RX, SB02OD, SB02SD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LE.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -20 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -22 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -24 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -26 + ELSE +C +C Compute workspace. +C + IWB = ( N + NP1 + 1 )*( N + M2 ) + + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ) + IWC = ( N + NP2 )*( N + M1 + 1 ) + + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ) + IWD = 13*N*N + 2*M*M + N*( 8*M + NP2 ) + M1*( M2 + NP2 ) + + $ 6*N + MAX( 14*N + 23, 16*N, 2*N + M, 3*M ) + IWG = 13*N*N + M*M + ( 8*N + M + M2 + 2*NP2 )*( M2 + NP2 ) + + $ 6*N + N*( M + NP2 ) + + $ MAX( 14*N + 23, 16*N, 2*N + M2 + NP2, 3*( M2 + NP2 ) ) + MINWRK = MAX( IWB, IWC, IWD, IWG ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -31 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + RCOND( 5 ) = ONE + RCOND( 6 ) = ONE + RCOND( 7 ) = ONE + RCOND( 8 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance in rank determination. +C + TOLL = THOUSN*DLAMCH( 'Epsilon' ) + END IF +C +C Workspace usage. +C + IWS = (N+NP1)*(N+M2) + 1 + IWRK = IWS + (N+M2) +C +C jTheta +C Determine if |A-e I B2 | has full column rank at +C | C1 D12| +C Theta = Pi/2 . +C Workspace: need (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)); +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP1 ) + CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( N+1 ), N+NP1 ) + CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, + $ DWORK( (N+NP1)*N+1 ), N+NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( (N+NP1)*N+N+1 ), N+NP1 ) + CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK, N+NP1, DWORK( IWS ), + $ DWORK, N+NP1, DWORK, N+M2, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+N+M2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Workspace usage. +C + IWS = (N+NP2)*(N+M1) + 1 + IWRK = IWS + (N+NP2) +C +C jTheta +C Determine if |A-e I B1 | has full row rank at +C | C2 D21| +C Theta = Pi/2 . +C Workspace: need (N+NP2)*(N+M1+1) + +C MAX(3*(N+NP2)+N+M1,5*(N+NP2)); +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( N+1 ), + $ N+NP2 ) + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( (N+NP2)*N+1 ), + $ N+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( (N+NP2)*N+N+1 ), N+NP2 ) + CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK, N+NP2, DWORK( IWS ), + $ DWORK, N+NP2, DWORK, N+M1, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+N+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWS = NP1*M2 + 1 + IWRK = IWS + M2 +C +C Determine if D12 has full column rank. +C Workspace: need (NP1+1)*M2 + MAX(3*M2+NP1,5*M2); +C prefer larger. +C + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, DWORK, NP1 ) + CALL DGESVD( 'N', 'N', NP1, M2, DWORK, NP1, DWORK( IWS ), DWORK, + $ NP1, DWORK, M2, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+M2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWS = NP2*M1 + 1 + IWRK = IWS + NP2 +C +C Determine if D21 has full row rank. +C Workspace: need NP2*(M1+1) + MAX(3*NP2+M1,5*NP2); +C prefer larger. +C + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, NP2 ) + CALL DGESVD( 'N', 'N', NP2, M1, DWORK, NP2, DWORK( IWS ), DWORK, + $ NP2, DWORK, M1, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWV = 1 + IWB = IWV + M*M + IWC = IWB + N*M1 + IWD = IWC + ( M2 + NP2 )*N + IWQ = IWD + ( M2 + NP2 )*M1 + IWL = IWQ + N*N + IWR = IWL + N*M + IWI = IWR + 2*N + IWH = IWI + 2*N + IWS = IWH + 2*N + IWT = IWS + ( 2*N + M )*( 2*N + M ) + IWU = IWT + ( 2*N + M )*2*N + IWRK = IWU + 4*N*N + IR2 = IWV + M1 + IR3 = IR2 + M*M1 +C +C Compute R0 = |D11'||D11 D12| -|gamma^2*Im1 0| . +C |D12'| | 0 0| +C + CALL DSYRK( 'Lower', 'Transpose', M, NP1, ONE, D, LDD, ZERO, + $ DWORK, M ) + DO 10 J = 1, M*M1, M + 1 + DWORK( J ) = DWORK( J ) - GAMMA*GAMMA + 10 CONTINUE +C +C Compute C1'*C1 . +C + CALL DSYRK( 'Lower', 'Transpose', N, NP1, ONE, C, LDC, ZERO, + $ DWORK( IWQ ), N ) +C +C Compute C1'*|D11 D12| . +C + CALL DGEMM( 'Transpose', 'NoTranspose', N, M, NP1, ONE, C, LDC, + $ D, LDD, ZERO, DWORK( IWL ), N ) +C +C Solution of the X-Riccati equation. +C Workspace: need 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + +C 6*N + max(14*N+23,16*N,2*N+M,3*M); +C prefer larger. +C + CALL SB02OD( 'D', 'B', 'N', 'L', 'N', 'S', N, M, NP, A, LDA, B, + $ LDB, DWORK( IWQ ), N, DWORK, M, DWORK( IWL ), N, + $ RCOND2, X, LDX, DWORK( IWR ), DWORK( IWI ), + $ DWORK( IWH ), DWORK( IWS ), 2*N+M, DWORK( IWT ), + $ 2*N+M, DWORK( IWU ), 2*N, TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Condition estimation. +C Workspace: need 4*N*N + 2*M*M + N*(3*M+NP2) + M1*(M2+NP2) + +C max(5*N,max(3,2*N*N)+N*N); +C prefer larger. +C + IWS = IWR + IWH = IWS + M*M + IWT = IWH + N*M + IWU = IWT + N*N + IWG = IWU + N*N + IWRK = IWG + N*N + CALL DLACPY( 'Lower', M, M, DWORK, M, DWORK( IWS ), M ) + CALL DSYTRF( 'Lower', M, DWORK( IWS ), M, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + CALL MA02AD( 'Full', N, M, B, LDB, DWORK( IWH ), M ) + CALL DSYTRS( 'Lower', M, N, DWORK( IWS ), M, IWORK, DWORK( IWH ), + $ M, INFO2 ) + CALL MB01RX( 'Left', 'Lower', 'NoTranspose', N, M, ZERO, ONE, + $ DWORK( IWG ), N, B, LDB, DWORK( IWH ), M, INFO2 ) + CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, A, LDA, DWORK( IWT ), N, + $ DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, X, + $ LDX, SEPD, RCOND( 7 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 7 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWRK = IWR +C +C Compute the lower triangle of |R1 R2'| = R0 + B'*X*B . +C |R2 R3 | +C + CALL MB01RU( 'Lower', 'Transpose', M, N, ONE, ONE, DWORK, M, + $ B, LDB, X, LDX, DWORK( IWRK ), M*N, INFO2 ) +C +C Compute the Cholesky factorization of R3, R3 = V12'*V12 . +C Note that V12' is stored. +C + ANORM = DLANSY( '1', 'Lower', M2, DWORK( IR3 ), M, DWORK( IWRK ) ) + CALL DPOTRF( 'Lower', M2, DWORK( IR3 ), M, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Lower', M2, DWORK( IR3 ), M, ANORM, RCOND( 1 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 1 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C + CALL DTRCON( '1', 'Lower', 'NonUnit', M2, DWORK( IR3 ), M, + $ RCOND( 5 ), DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 5 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute R2 <- inv(V12')*R2 . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, M1, + $ ONE, DWORK( IR3 ), M, DWORK( IR2 ), M ) +C +C Compute -Nabla = R2'*inv(R3)*R2 - R1 . +C + CALL DSYRK( 'Lower', 'Transpose', M1, M2, ONE, DWORK( IR2 ), M, + $ -ONE, DWORK, M ) +C +C Compute the Cholesky factorization of -Nabla, -Nabla = V21t'*V21t. +C Note that V21t' is stored. +C + ANORM = DLANSY( '1', 'Lower', M1, DWORK, M, DWORK( IWRK ) ) + CALL DPOTRF( 'Lower', M1, DWORK, M, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Lower', M1, DWORK, M, ANORM, RCOND( 2 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 2 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C + CALL DTRCON( '1', 'Lower', 'NonUnit', M1, DWORK, M, RCOND( 3 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 3 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute X*A . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, X, LDX, + $ A, LDA, ZERO, DWORK( IWQ ), N ) +C +C Compute |L1| = |D11'|*C1 + B'*X*A . +C |L2| = |D12'| +C + CALL MA02AD( 'Full', N, M, DWORK( IWL ), N, DWORK( IWRK ), M ) + CALL DLACPY( 'Full', M, N, DWORK( IWRK ), M, DWORK( IWL ), M ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, N, ONE, B, LDB, + $ DWORK( IWQ ), N, ONE, DWORK( IWL ), M ) +C +C Compute L2 <- inv(V12')*L2 . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, N, ONE, + $ DWORK( IR3 ), M, DWORK( IWL+M1 ), M ) +C +C Compute L_Nabla = L1 - R2'*inv(R3)*L2 . +C + CALL DGEMM( 'Transpose', 'NoTranspose', M1, N, M2, -ONE, + $ DWORK( IR2 ), M, DWORK( IWL+M1 ), M, ONE, + $ DWORK( IWL ), M ) +C +C Compute L_Nabla <- inv(V21t')*L_Nabla . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M1, N, ONE, + $ DWORK, M, DWORK( IWL ), M ) +C +C Compute Bt1 = B1*inv(V21t) . +C + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IWB ), N ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', N, M1, ONE, + $ DWORK, M, DWORK( IWB ), N ) +C +C Compute At . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M1, ONE, + $ DWORK( IWB ), N, DWORK( IWL ), M, ONE, AK, LDAK ) +C +C Scale Bt1 . +C + CALL DSCAL( N*M1, GAMMA, DWORK( IWB ), 1 ) +C +C Compute |Dt11| = |R2 |*inv(V21t) . +C |Dt21| |D21| +C + CALL DLACPY( 'Full', M2, M1, DWORK( IR2 ), M, DWORK( IWD ), + $ M2+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK( IWD+M2 ), + $ M2+NP2 ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M2+NP2, + $ M1, ONE, DWORK, M, DWORK( IWD ), M2+NP2 ) +C +C Compute Ct = |Ct1| = |L2| + |Dt11|*inv(V21t')*L_Nabla . +C |Ct2| = |C2| + |Dt21| +C + CALL DLACPY( 'Full', M2, N, DWORK( IWL+M1 ), M, DWORK( IWC ), + $ M2+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1 ), LDC, DWORK( IWC+M2 ), + $ M2+NP2 ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2+NP2, N, M1, ONE, + $ DWORK( IWD ), M2+NP2, DWORK( IWL ), M, ONE, + $ DWORK( IWC ), M2+NP2 ) +C +C Scale |Dt11| . +C |Dt21| +C + CALL DSCAL( ( M2+NP2 )*M1, GAMMA, DWORK( IWD ), 1 ) +C +C Workspace usage. +C + IWW = IWD + ( M2 + NP2 )*M1 + IWQ = IWW + ( M2 + NP2 )*( M2 + NP2 ) + IWL = IWQ + N*N + IWR = IWL + N*( M2 + NP2 ) + IWI = IWR + 2*N + IWH = IWI + 2*N + IWS = IWH + 2*N + IWT = IWS + ( 2*N + M2 + NP2 )*( 2*N + M2 + NP2 ) + IWU = IWT + ( 2*N + M2 + NP2 )*2*N + IWG = IWU + 4*N*N + IWRK = IWG + ( M2 + NP2 )*N + IS2 = IWW + ( M2 + NP2 )*M2 + IS3 = IS2 + M2 +C +C Compute S0 = |Dt11||Dt11' Dt21'| -|gamma^2*Im2 0| . +C |Dt21| | 0 0| +C + CALL DSYRK( 'Upper', 'NoTranspose', M2+NP2, M1, ONE, DWORK( IWD ), + $ M2+NP2, ZERO, DWORK( IWW ), M2+NP2 ) + DO 20 J = IWW, IWW - 1 + ( M2 + NP2 )*M2, M2 + NP2 + 1 + DWORK( J ) = DWORK( J ) - GAMMA*GAMMA + 20 CONTINUE +C +C Compute Bt1*Bt1' . +C + CALL DSYRK( 'Upper', 'NoTranspose', N, M1, ONE, DWORK( IWB ), N, + $ ZERO, DWORK( IWQ ), N ) +C +C Compute Bt1*|Dt11' Dt21'| . +C + CALL DGEMM( 'NoTranspose', 'Transpose', N, M2+NP2, M1, ONE, + $ DWORK( IWB ), N, DWORK( IWD ), M2+NP2, ZERO, + $ DWORK( IWL ), N ) +C +C Transpose At in situ (in AK) . +C + DO 30 J = 2, N + CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) + 30 CONTINUE +C +C Transpose Ct . +C + CALL MA02AD( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, + $ DWORK( IWG ), N ) +C +C Solution of the Z-Riccati equation. +C Workspace: need 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + +C N*(M+NP2) + 6*N + +C max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); +C prefer larger. +C + CALL SB02OD( 'D', 'B', 'N', 'U', 'N', 'S', N, M2+NP2, NP, AK, + $ LDAK, DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWW ), + $ M2+NP2, DWORK( IWL ), N, RCOND2, Z, LDZ, DWORK( IWR), + $ DWORK( IWI ), DWORK( IWH ), DWORK( IWS ), 2*N+M2+NP2, + $ DWORK( IWT ), 2*N+M2+NP2, DWORK( IWU ), 2*N, TOLL, + $ IWORK, DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 7 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Condition estimation. +C Workspace: need 4*N*N + M*M + 2*(M2+NP2)*(M2+NP2)+ +C N*(M+2*M2+3*NP2) + (M2+NP2)*M1 + +C max(5*N,max(3,2*N*N)+N*N); +C prefer larger. +C + IWS = IWR + IWH = IWS + ( M2 + NP2 )*( M2 + NP2 ) + IWT = IWH + N*( M2 + NP2 ) + IWU = IWT + N*N + IWG = IWU + N*N + IWRK = IWG + N*N + CALL DLACPY( 'Upper', M2+NP2, M2+NP2, DWORK( IWW ), M2+NP2, + $ DWORK( IWS ), M2+NP2 ) + CALL DSYTRF( 'Upper', M2+NP2, DWORK( IWS ), M2+NP2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + CALL DLACPY( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, + $ DWORK( IWH ), M2+NP2 ) + CALL DSYTRS( 'Upper', M2+NP2, N, DWORK( IWS ), M2+NP2, IWORK, + $ DWORK( IWH ), M2+NP2, INFO2 ) + CALL MB01RX( 'Left', 'Upper', 'Transpose', N, M2+NP2, ZERO, ONE, + $ DWORK( IWG ), N, DWORK( IWC ), M2+NP2, DWORK( IWH ), + $ M2+NP2, INFO2 ) + CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWT ), + $ N, DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Z, LDZ, SEPD, RCOND( 8 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 8 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWRK = IWR +C +C Compute the upper triangle of +C |St1 St2| = S0 + |Ct1|*Z*|Ct1' Ct2'| . +C |St2' St3| |Ct2| +C + CALL MB01RU( 'Upper', 'NoTranspose', M2+NP2, N, ONE, ONE, + $ DWORK( IWW ), M2+NP2, DWORK( IWC ), M2+NP2, Z, LDZ, + $ DWORK( IWRK ), (M2+NP2)*N, INFO2 ) +C +C Compute the Cholesky factorization of St3, St3 = U12'*U12 . +C + ANORM = DLANSY( '1', 'Upper', NP2, DWORK( IS3 ), M2+NP2, + $ DWORK( IWRK ) ) + CALL DPOTRF( 'Upper', NP2, DWORK( IS3 ), M2+NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Upper', NP2, DWORK( IS3 ), M2+NP2, ANORM, + $ RCOND( 4 ), DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 4 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute St2 <- St2*inv(U12) . +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M2, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) +C +C Check the negative definiteness of St1 - St2*inv(St3)*St2' . +C + CALL DSYRK( 'Upper', 'NoTranspose', M2, NP2, ONE, DWORK( IS2 ), + $ M2+NP2, -ONE, DWORK( IWW ), M2+NP2 ) + CALL DPOTRF( 'Upper', M2, DWORK( IWW ), M2+NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF +C +C Restore At in situ . +C + DO 40 J = 2, N + CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) + 40 CONTINUE +C +C Compute At*Z . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, AK, LDAK, + $ Z, LDZ, ZERO, DWORK( IWRK ), N ) +C +C Compute Mt2 = Bt1*Dt21' + At*Z*Ct2' in BK . +C + CALL DLACPY( 'Full', N, NP2, DWORK( IWL+N*M2 ), N, BK, LDBK ) + CALL DGEMM( 'NoTranspose', 'Transpose', N, NP2, N, ONE, + $ DWORK( IWRK ), N, DWORK( IWC+M2 ), M2+NP2, ONE, + $ BK, LDBK ) +C +C Compute St2 <- St2*inv(U12') . +C + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M2, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) +C +C Compute DKHAT = -inv(V12)*St2 in DK . +C + CALL DLACPY( 'Full', M2, NP2, DWORK( IS2 ), M2+NP2, DK, LDDK ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, NP2, + $ -ONE, DWORK( IR3 ), M, DK, LDDK ) +C +C Compute CKHAT = -inv(V12)*(Ct1 - St2*inv(St3)*Ct2) in CK . +C + CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, N, NP2, -ONE, + $ DWORK( IS2 ), M2+NP2, DWORK( IWC+M2 ), M2+NP2, ONE, + $ CK, LDCK ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, N, -ONE, + $ DWORK( IR3 ), M, CK, LDCK ) +C +C Compute Mt2*inv(St3) in BK . +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) +C +C Compute AKHAT in AK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, ONE, + $ B( 1, M1+1 ), LDB, CK, LDCK, ONE, AK, LDAK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, NP2, -ONE, BK, + $ LDBK, DWORK( IWC+M2 ), M2+NP2, ONE, AK, LDAK ) +C +C Compute BKHAT in BK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, ONE, + $ B( 1, M1+1 ), LDB, DK, LDDK, ONE, BK, LDBK ) +C +C Compute Im2 + DKHAT*D22 . +C + IWRK = M2*M2 + 1 + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, M2, NP2, ONE, DK, + $ LDDK, D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 8 + RETURN + END IF + CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND( 6 ), DWORK( IWRK ), + $ IWORK( M2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 6 ).LT.TOLL ) THEN + INFO = 8 + RETURN + END IF +C +C Compute CK . +C + CALL DGETRS( 'NoTranspose', M2, N, DWORK, M2, IWORK, CK, LDCK, + $ INFO2 ) +C +C Compute DK . +C + CALL DGETRS( 'NoTranspose', M2, NP2, DWORK, M2, IWORK, DK, LDDK, + $ INFO2 ) +C +C Compute AK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M2, NP2, ONE, BK, + $ LDBK, D( NP1+1, M1+1 ), LDD, ZERO, DWORK, N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, -ONE, DWORK, + $ N, CK, LDCK, ONE, AK, LDAK ) +C +C Compute BK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, -ONE, DWORK, + $ N, DK, LDDK, ONE, BK, LDBK ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10DD *** + END diff --git a/modules/cacsd/src/slicot/sb10dd.lo b/modules/cacsd/src/slicot/sb10dd.lo new file mode 100755 index 000000000..d5b8a6722 --- /dev/null +++ b/modules/cacsd/src/slicot/sb10dd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb10dd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb10dd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb10fd.f b/modules/cacsd/src/slicot/sb10fd.f new file mode 100755 index 000000000..d2fa3376c --- /dev/null +++ b/modules/cacsd/src/slicot/sb10fd.f @@ -0,0 +1,453 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To compute the matrices of an H-infinity (sub)optimal n-state +C controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C using modified Glover's and Doyle's 1988 formulas, for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C (A3) | A-j*omega*I B2 | has full column rank for all omega, +C | C1 D12 | +C +C (A4) | A-j*omega*I B1 | has full row rank for all omega. +C | C2 D21 | +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations for computing the normalized form in +C SLICOT Library routine SB10PD. Transformation matrices +C whose reciprocal condition numbers are less than TOL are +C not allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK = max(2*max(N,M-NCON,NP-NMEAS,NCON),N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + +C max(1,LW1,LW2,LW3,LW4,LW5,LW6), where +C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), +C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), +C LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), +C LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), +C LW5 = 2*N*N + N*(M+NP) + +C max(1,M*M + max(2*M1,3*N*N+max(N*M,10*N*N+12*N+5)), +C NP*NP + max(2*NP1,3*N*N + +C max(N*NP,10*N*N+12*N+5))), +C LW6 = 2*N*N + N*(M+NP) + +C max(1, M2*NP2 + NP2*NP2 + M2*M2 + +C max(D1*D1 + max(2*D1, (D1+D2)*NP2), +C D2*D2 + max(2*D2, D2*M2), 3*N, +C N*(2*NP2 + M2) + +C max(2*N*M2, M2*NP2 + +C max(M2*M2+3*M2, NP2*(2*NP2+ +C M2+max(NP2,N)))))), +C with D1 = NP1 - M2, D2 = M1 - NP2, +C NP1 = NP - NP2, M1 = M - M2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), +C 2*N*(N+2*Q)+max(1,4*Q*Q+ +C max(2*Q,3*N*N+max(2*N*Q,10*N*N+12*N+5)), +C Q*(3*N+3*Q+max(2*N,4*Q+max(N,Q))))). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix | A-j*omega*I B2 | had not full +C | C1 D12 | +C column rank in respect to the tolerance EPS; +C = 2: if the matrix | A-j*omega*I B1 | had not full row +C | C2 D21 | +C rank in respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C = 6: if the controller is not admissible (too small value +C of gamma); +C = 7: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 8: if the Y-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is +C zero [3]. +C +C METHOD +C +C The routine implements the Glover's and Doyle's 1988 formulas [1], +C [2] modified to improve the efficiency as described in [3]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of continuous-time +C linear control systems. +C Rep. 98-14, Department of Engineering, Leicester University, +C Leicester, U.K., 1998. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations and on the condition numbers of +C the two Riccati equations, as given by the values of RCOND(1), +C RCOND(2), RCOND(3) and RCOND(4), respectively. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999, Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA, TOL +C .. +C .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( 4 ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY, + $ IWX, IWY, LW1, LW2, LW3, LW4, LW5, LW6, + $ LWAMAX, M1, M2, MINWRK, ND1, ND2, NP1, NP2 + DOUBLE PRECISION TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DLACPY, SB10PD, SB10QD, SB10RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -20 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -22 + ELSE +C +C Compute workspace. +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + LW1 = ( N + NP1 + 1 )*( N + M2 ) + MAX( 3*( N + M2 ) + N + NP1, + $ 5*( N + M2 ) ) + LW2 = ( N + NP2 )*( N + M1 + 1 ) + MAX( 3*( N + NP2 ) + N + + $ M1, 5*( N + NP2 ) ) + LW3 = M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, 5*M2 ) + LW4 = NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, 5*NP2 ) + LW5 = 2*N*N + N*( M + NP ) + + $ MAX( 1, M*M + MAX( 2*M1, 3*N*N + + $ MAX( N*M, 10*N*N + 12*N + 5 ) ), + $ NP*NP + MAX( 2*NP1, 3*N*N + + $ MAX( N*NP, 10*N*N + 12*N + 5 ) ) ) + LW6 = 2*N*N + N*( M + NP ) + + $ MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 + + $ MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ), + $ ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N, + $ N*( 2*NP2 + M2 ) + + $ MAX( 2*N*M2, M2*NP2 + + $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + + $ M2 + MAX( NP2, N ) ) ) ) ) ) + MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + + $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -27 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10FD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage. +C + IWC = 1 + N*M + IWD = IWC + NP*N + IWTU = IWD + NP*M + IWTY = IWTU + M2*M2 + IWRK = IWTY + NP2*NP2 +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) +C +C Transform the system so that D12 and D21 satisfy the formulas +C in the computation of the Hinf (sub)optimal controller. +C + CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ), + $ M2, DWORK( IWTY ), NP2, RCOND, TOLL, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C + IWX = IWRK + IWY = IWX + N*N + IWF = IWY + N*N + IWH = IWF + M*N + IWRK = IWH + N*NP +C +C Compute the (sub)optimal state feedback and output injection +C matrices. +C + CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), + $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, + $ BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute the Hinf (sub)optimal controller. +C + CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), + $ NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK, + $ LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.EQ.1 ) THEN + INFO = 6 + RETURN + ELSE IF( INFO2.EQ.2 ) THEN + INFO = 9 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10FD *** + END diff --git a/modules/cacsd/src/slicot/sb10fd.lo b/modules/cacsd/src/slicot/sb10fd.lo new file mode 100755 index 000000000..f439c58a4 --- /dev/null +++ b/modules/cacsd/src/slicot/sb10fd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb10fd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb10fd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb10pd.f b/modules/cacsd/src/slicot/sb10pd.f new file mode 100755 index 000000000..d12b177f8 --- /dev/null +++ b/modules/cacsd/src/slicot/sb10pd.f @@ -0,0 +1,489 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To reduce the matrices D12 and D21 of the linear time-invariant +C system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C to unit diagonal form, to transform the matrices B, C, and D11 to +C satisfy the formulas in the computation of an H2 and H-infinity +C (sub)optimal controllers and to check the rank conditions. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading NP-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading NP-by-N part of this array contains +C the transformed system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading NP-by-M part of this array must +C contain the system input/output matrix D. The +C NMEAS-by-NCON trailing submatrix D22 is not referenced. +C On exit, the leading (NP-NMEAS)-by-(M-NCON) part of this +C array contains the transformed submatrix D11. +C The transformed submatrices D12 = [ 0 Im2 ]' and +C D21 = [ 0 Inp2 ] are not stored. The corresponding part +C of this array contains no useful information. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array contains the +C control transformation matrix TU. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array contains the +C measurement transformation matrix TY. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C RCOND (output) DOUBLE PRECISION array, dimension (2) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix TU; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix TY. +C RCOND is set even if INFO = 3 or INFO = 4; if INFO = 3, +C then RCOND(2) was not computed, but it is set to 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations. Transformation matrices TU and TY whose +C reciprocal condition numbers are less than TOL are not +C allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX(1,LW1,LW2,LW3,LW4), where +C LW1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)), +C LW2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)), +C LW3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2), +C LW4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2), +C with M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is +C MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix | A B2 | had not full column rank +C | C1 D12 | +C in respect to the tolerance EPS; +C = 2: if the matrix | A B1 | had not full row rank in +C | C2 D21 | +C respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C +C METHOD +C +C The routine performs the transformations described in [2]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The precision of the transformations can be controlled by the +C condition numbers of the matrices TU and TY as given by the +C values of RCOND(1) and RCOND(2), respectively. An error return +C with INFO = 3 or INFO = 4 will be obtained if the condition +C number of TU or TY, respectively, would exceed 1/TOL. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Feb. 2000. +C +C KEYWORDS +C +C H-infinity optimal control, robust control, singular value +C decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDTU, LDTY, LDWORK, + $ M, N, NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), RCOND( 2 ), + $ TU( LDTU, * ), TY( LDTY, * ) +C .. +C .. Local Scalars .. + INTEGER IEXT, INFO2, IQ, IWRK, J, LWAMAX, M1, M2, + $ MINWRK, ND1, ND2, NP1, NP2 + DOUBLE PRECISION EPS, TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -15 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -17 + ELSE +C +C Compute workspace. +C + MINWRK = MAX( 1, + $ ( N + NP1 + 1 )*( N + M2 ) + + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), + $ ( N + NP2 )*( N + M1 + 1 ) + + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), + $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, + $ 5*M2 ), + $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, + $ 5*NP2 ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -21 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + EPS = DLAMCH( 'Epsilon' ) + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for condition tests. +C + TOLL = SQRT( EPS ) + END IF +C +C Determine if |A-jwI B2 | has full column rank at w = 0. +C | C1 D12| +C Workspace: need (N+NP1+1)*(N+M2) + +C max(3*(N+M2)+N+NP1,5*(N+M2)); +C prefer larger. +C + IEXT = N + M2 + 1 + IWRK = IEXT + ( N + NP1 )*( N + M2 ) + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP1 ) + CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( IEXT+N ), N+NP1 ) + CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, + $ DWORK( IEXT+(N+NP1)*N ), N+NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( IEXT+(N+NP1)*N+N ), N+NP1 ) + CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK( IEXT ), N+NP1, DWORK, + $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + IF( DWORK( N+M2 )/DWORK( 1 ).LE.EPS ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Determine if |A-jwI B1 | has full row rank at w = 0. +C | C2 D21| +C Workspace: need (N+NP2)*(N+M1+1) + +C max(3*(N+NP2)+N+M1,5*(N+NP2)); +C prefer larger. +C + IEXT = N + NP2 + 1 + IWRK = IEXT + ( N + NP2 )*( N + M1 ) + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( IEXT+N ), + $ N+NP2 ) + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IEXT+(N+NP2)*N ), + $ N+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( IEXT+(N+NP2)*N+N ), N+NP2 ) + CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK( IEXT ), N+NP2, DWORK, + $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + IF( DWORK( N+NP2 )/DWORK( 1 ).LE.EPS ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has +C full column rank. V12' is stored in TU. +C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); +C prefer larger. +C + IQ = M2 + 1 + IWRK = IQ + NP1*NP1 +C + CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, + $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF +C + RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) + IF( RCOND( 1 ).LE.TOLL ) THEN + RCOND( 2 ) = ZERO + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine Q12. +C + IF( ND1.GT.0 ) THEN + CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), + $ LDD ) + CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, + $ DWORK( IQ ), NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( IQ+NP1*ND1 ), NP1 ) + END IF +C +C Determine Tu by transposing in-situ and scaling. +C + DO 10 J = 1, M2 - 1 + CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) + 10 CONTINUE +C + DO 20 J = 1, M2 + CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) + 20 CONTINUE +C +C Determine C1 =: Q12'*C1. +C Workspace: M2 + NP1*NP1 + NP1*N. +C + CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) + LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) +C +C Determine D11 =: Q12'*D11. +C Workspace: M2 + NP1*NP1 + NP1*M1. +C + CALL DGEMM( 'T', 'N', NP1, M1, NP1, ONE, DWORK( IQ ), NP1, D, LDD, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) + LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) +C +C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has +C full row rank. U21 is stored in TY. +C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); +C prefer larger. +C + IQ = NP2 + 1 + IWRK = IQ + M1*M1 +C + CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, + $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF +C + RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) + IF( RCOND( 2 ).LE.TOLL ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine Q21. +C + IF( ND2.GT.0 ) THEN + CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), + $ LDD ) + CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), + $ M1 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( IQ+ND2 ), M1 ) + END IF +C +C Determine Ty by scaling and transposing in-situ. +C + DO 30 J = 1, NP2 + CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) + 30 CONTINUE +C + DO 40 J = 1, NP2 - 1 + CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) + 40 CONTINUE +C +C Determine B1 =: B1*Q21'. +C Workspace: NP2 + M1*M1 + N*M1. +C + CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, + $ ZERO, DWORK( IWRK ), N ) + CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) + LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) +C +C Determine D11 =: D11*Q21'. +C Workspace: NP2 + M1*M1 + NP1*M1. +C + CALL DGEMM( 'N', 'T', NP1, M1, M1, ONE, D, LDD, DWORK( IQ ), M1, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) + LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) +C +C Determine B2 =: B2*Tu. +C Workspace: N*M2. +C + CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, + $ ZERO, DWORK, N ) + CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) +C +C Determine C2 =: Ty*C2. +C Workspace: NP2*N. +C + CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, + $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) + CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) +C + LWAMAX = MAX( N*MAX( M2, NP2 ), LWAMAX ) + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10PD *** + END diff --git a/modules/cacsd/src/slicot/sb10pd.lo b/modules/cacsd/src/slicot/sb10pd.lo new file mode 100755 index 000000000..13562773f --- /dev/null +++ b/modules/cacsd/src/slicot/sb10pd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb10pd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb10pd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb10qd.f b/modules/cacsd/src/slicot/sb10qd.f new file mode 100755 index 000000000..365745944 --- /dev/null +++ b/modules/cacsd/src/slicot/sb10qd.f @@ -0,0 +1,586 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +C +C PURPOSE +C +C To compute the state feedback and the output injection +C matrices for an H-infinity (sub)optimal n-state controller, +C using Glover's and Doyle's 1988 formulas, for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank with D12 = | 0 | and D21 is +C | I | +C full row rank with D21 = | 0 I | as obtained by the +C subroutine SB10PD, +C +C (A3) | A-j*omega*I B2 | has full column rank for all omega, +C | C1 D12 | +C +C +C (A4) | A-j*omega*I B1 | has full row rank for all omega. +C | C2 D21 | +C +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the state +C feedback matrix F. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= max(1,M). +C +C H (output) DOUBLE PRECISION array, dimension (LDH,NP) +C The leading N-by-NP part of this array contains the output +C injection matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the matrix +C Y, solution of the Y-Riccati equation. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= max(1,N). +C +C XYCOND (output) DOUBLE PRECISION array, dimension (2) +C XYCOND(1) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C XYCOND(2) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*max(N,M-NCON,NP-NMEAS),N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(1,M*M + max(2*M1,3*N*N + +C max(N*M,10*N*N+12*N+5)), +C NP*NP + max(2*NP1,3*N*N + +C max(N*NP,10*N*N+12*N+5))), +C where M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is +C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the controller is not admissible (too small value +C of gamma); +C = 2: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 3: if the Y-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties). +C +C METHOD +C +C The routine implements the Glover's and Doyle's formulas [1],[2] +C modified as described in [3]. The X- and Y-Riccati equations +C are solved with condition and accuracy estimates [4]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of continuous-time +C linear control systems. +C Rep. 98-14, Department of Engineering, Leicester University, +C Leicester, U.K., 1998. +C +C [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. +C DGRSVX and DMSRIC: Fortan 77 subroutines for solving +C continuous-time matrix algebraic Riccati equations with +C condition and accuracy estimates. +C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. +C Chemnitz, May 1998. +C +C NUMERICAL ASPECTS +C +C The precision of the solution of the matrix Riccati equations +C can be controlled by the values of the condition numbers +C XYCOND(1) and XYCOND(2) of these equations. +C +C FURTHER COMMENTS +C +C The Riccati equations are solved by the Schur approach +C implementing condition and accuracy estimates. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDH, LDWORK, + $ LDX, LDY, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), F( LDF, * ), + $ H( LDH, * ), X( LDX, * ), XYCOND( 2 ), + $ Y( LDY, * ) + LOGICAL BWORK( * ) +C +C .. +C .. Local Scalars .. + INTEGER INFO2, IW2, IWA, IWG, IWI, IWQ, IWR, IWRK, IWS, + $ IWT, IWV, LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, + $ NN, NP1, NP2 + DOUBLE PRECISION ANORM, EPS, FERR, RCOND, SEP +C .. +C .. External Functions .. +C + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, DSYCON, DSYMM, DSYRK, + $ DSYTRF, DSYTRI, MB01RU, MB01RX, SB02RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS + NN = N*N +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE +C +C Compute workspace. +C + MINWRK = MAX( 1, M*M + MAX( 2*M1, 3*NN + + $ MAX( N*M, 10*NN + 12*N + 5 ) ), + $ NP*NP + MAX( 2*NP1, 3*NN + + $ MAX( N*NP, 10*NN + 12*N + 5 ) ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -26 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + XYCOND( 1 ) = ONE + XYCOND( 2 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF + ND1 = NP1 - M2 + ND2 = M1 - NP2 + N2 = 2*N +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Workspace usage. +C + IWA = M*M + 1 + IWQ = IWA + NN + IWG = IWQ + NN + IW2 = IWG + NN +C +C Compute |D1111'||D1111 D1112| - gamma^2*Im1 . +C |D1112'| +C + CALL DLASET( 'L', M1, M1, ZERO, -GAMMA*GAMMA, DWORK, M ) + IF( ND1.GT.0 ) + $ CALL DSYRK( 'L', 'T', M1, ND1, ONE, D, LDD, ONE, DWORK, M ) +C +C Compute inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . +C |D1112'| +C + IWRK = IWA + ANORM = DLANSY( 'I', 'L', M1, DWORK, M, DWORK( IWRK ) ) + CALL DSYTRF( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 + CALL DSYCON( 'L', M1, DWORK, M, IWORK, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( M1+1 ), INFO2 ) + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(R) block by block. +C + CALL DSYTRI( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), INFO2 ) +C +C Compute -|D1121 D1122|*inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . +C |D1112'| +C + CALL DSYMM( 'R', 'L', M2, M1, -ONE, DWORK, M, D( ND1+1, 1 ), LDD, + $ ZERO, DWORK( M1+1 ), M ) +C +C Compute |D1121 D1122|*inv(|D1111'|*|D1111 D1112| - +C |D1112'| +C +C gamma^2*Im1)*|D1121'| + Im2 . +C |D1122'| +C + CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( M1*(M+1)+1 ), M ) + CALL MB01RX( 'Right', 'Lower', 'Transpose', M2, M1, ONE, -ONE, + $ DWORK( M1*(M+1)+1 ), M, D( ND1+1, 1 ), LDD, + $ DWORK( M1+1 ), M, INFO2 ) +C +C Compute D11'*C1 . +C + CALL DGEMM( 'T', 'N', M1, N, NP1, ONE, D, LDD, C, LDC, ZERO, + $ DWORK( IW2 ), M ) +C +C Compute D1D'*C1 . +C + CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, DWORK( IW2+M1 ), + $ M ) +C +C Compute inv(R)*D1D'*C1 in F . +C + CALL DSYMM( 'L', 'L', M, N, ONE, DWORK, M, DWORK( IW2 ), M, ZERO, + $ F, LDF ) +C +C Compute Ax = A - B*inv(R)*D1D'*C1 . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) + CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, F, LDF, ONE, + $ DWORK( IWA ), N ) +C +C Compute Cx = C1'*C1 - C1'*D1D*inv(R)*D1D'*C1 . +C + IF( ND1.EQ.0 ) THEN + CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + ELSE + CALL DSYRK( 'L', 'T', N, NP1, ONE, C, LDC, ZERO, + $ DWORK( IWQ ), N ) + CALL MB01RX( 'Left', 'Lower', 'Transpose', N, M, ONE, -ONE, + $ DWORK( IWQ ), N, DWORK( IW2 ), M, F, LDF, INFO2 ) + END IF +C +C Compute Dx = B*inv(R)*B' . +C + IWRK = IW2 + CALL MB01RU( 'Lower', 'NoTranspose', N, M, ZERO, ONE, + $ DWORK( IWG ), N, B, LDB, DWORK, M, DWORK( IWRK ), + $ M*N, INFO2 ) +C +C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . +C Workspace: need M*M + 13*N*N + 12*N + 5; +C prefer larger. +C + IWT = IW2 + IWV = IWT + NN + IWR = IWV + NN + IWI = IWR + N2 + IWS = IWI + N2 + IWRK = IWS + 4*NN +C + CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', + $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', + $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, + $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute F = -inv(R)*|D1D'*C1 + B'*X| . +C + IWRK = IW2 + CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, X, LDX, ZERO, + $ DWORK( IWRK ), M ) + CALL DSYMM( 'L', 'L', M, N, -ONE, DWORK, M, DWORK( IWRK ), M, + $ -ONE, F, LDF ) +C +C Workspace usage. +C + IWA = NP*NP + 1 + IWQ = IWA + NN + IWG = IWQ + NN + IW2 = IWG + NN +C +C Compute |D1111|*|D1111' D1121'| - gamma^2*Inp1 . +C |D1121| +C + CALL DLASET( 'U', NP1, NP1, ZERO, -GAMMA*GAMMA, DWORK, NP ) + IF( ND2.GT.0 ) + $ CALL DSYRK( 'U', 'N', NP1, ND2, ONE, D, LDD, ONE, DWORK, NP ) +C +C Compute inv(|D1111|*|D1111' D1121'| - gamma^2*Inp1) . +C |D1121| +C + IWRK = IWA + ANORM = DLANSY( 'I', 'U', NP1, DWORK, NP, DWORK( IWRK ) ) + CALL DSYTRF( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) + CALL DSYCON( 'U', NP1, DWORK, NP, IWORK, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( NP1+1 ), INFO2 ) + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(RT) . +C + CALL DSYTRI( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), INFO2 ) +C +C Compute -inv(|D1111||D1111' D1121'| - gamma^2*Inp1)*|D1112| . +C |D1121| |D1122| +C + CALL DSYMM( 'L', 'U', NP1, NP2, -ONE, DWORK, NP, D( 1, ND2+1 ), + $ LDD, ZERO, DWORK( NP1*NP+1 ), NP ) +C +C Compute [D1112' D1122']*inv(|D1111||D1111' D1121'| - +C |D1121| +C +C gamma^2*Inp1)*|D1112| + Inp2 . +C |D1122| +C + CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( NP1*(NP+1)+1 ), + $ NP ) + CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, NP1, ONE, -ONE, + $ DWORK( NP1*(NP+1)+1 ), NP, D( 1, ND2+1 ), LDD, + $ DWORK( NP1*NP+1 ), NP, INFO2 ) +C +C Compute B1*D11' . +C + CALL DGEMM( 'N', 'T', N, NP1, M1, ONE, B, LDB, D, LDD, ZERO, + $ DWORK( IW2 ), N ) +C +C Compute B1*DD1' . +C + CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, + $ DWORK( IW2+NP1*N ), N ) +C +C Compute B1*DD1'*inv(RT) in H . +C + CALL DSYMM( 'R', 'U', N, NP, ONE, DWORK, NP, DWORK( IW2 ), N, + $ ZERO, H, LDH ) +C +C Compute Ay = A - B1*DD1'*inv(RT)*C . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) + CALL DGEMM( 'N', 'N', N, N, NP, -ONE, H, LDH, C, LDC, ONE, + $ DWORK( IWA ), N ) +C +C Compute Cy = B1*B1' - B1*DD1'*inv(RT)*DD1*B1' . +C + IF( ND2.EQ.0 ) THEN + CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + ELSE + CALL DSYRK( 'U', 'N', N, M1, ONE, B, LDB, ZERO, DWORK( IWQ ), + $ N ) + CALL MB01RX( 'Right', 'Upper', 'Transpose', N, NP, ONE, -ONE, + $ DWORK( IWQ ), N, H, LDH, DWORK( IW2 ), N, INFO2 ) + END IF +C +C Compute Dy = C'*inv(RT)*C . +C + IWRK = IW2 + CALL MB01RU( 'Upper', 'Transpose', N, NP, ZERO, ONE, DWORK( IWG ), + $ N, C, LDC, DWORK, NP, DWORK( IWRK), N*NP, INFO2 ) +C +C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . +C Workspace: need NP*NP + 13*N*N + 12*N + 5; +C prefer larger. +C + IWT = IW2 + IWV = IWT + NN + IWR = IWV + NN + IWI = IWR + N2 + IWS = IWI + N2 + IWRK = IWS + 4*NN +C + CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', + $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', + $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, + $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute H = -|B1*DD1' + Y*C'|*inv(RT) . +C + IWRK = IW2 + CALL DGEMM( 'N', 'T', N, NP, N, ONE, Y, LDY, C, LDC, ZERO, + $ DWORK( IWRK ), N ) + CALL DSYMM( 'R', 'U', N, NP, -ONE, DWORK, NP, DWORK( IWRK ), N, + $ -ONE, H, LDH ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10QD *** + END diff --git a/modules/cacsd/src/slicot/sb10qd.lo b/modules/cacsd/src/slicot/sb10qd.lo new file mode 100755 index 000000000..874075889 --- /dev/null +++ b/modules/cacsd/src/slicot/sb10qd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb10qd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb10qd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/sb10rd.f b/modules/cacsd/src/slicot/sb10rd.f new file mode 100755 index 000000000..4e708291b --- /dev/null +++ b/modules/cacsd/src/slicot/sb10rd.f @@ -0,0 +1,689 @@ + 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 RELEASE 4.0, WGS COPYRIGHT 1999. +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. +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 + IF( ND1.GT.0 ) THEN + IF( ND2.EQ.0 ) THEN +C +C Compute D21HAT'*D21HAT = Inp2 - D1112'*D1112/gamma^2 . +C + CALL DSYRK( 'U', 'T', NP2, ND1, -ONE/GAMMA**2, D, LDD, ONE, + $ DWORK( ID21 ), NP2 ) + ELSE +C +C Compute gdum = gamma^2*Ind1 - D1111*D1111' . +C + CALL DLASET( 'U', ND1, ND1, ZERO, GAMMA**2, DWORK( IW1 ), + $ ND1 ) + CALL DSYRK( 'U', 'N', ND1, ND2, -ONE, D, LDD, ONE, + $ DWORK( IW1 ), ND1 ) + ANORM = DLANSY( 'I', 'U', ND1, DWORK( IW1 ), ND1, + $ DWORK( IWRK ) ) + CALL DSYTRF( 'U', ND1, DWORK( IW1 ), ND1, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 + CALL DSYCON( 'U', ND1, DWORK( IW1 ), ND1, IWORK, ANORM, + $ RCOND, DWORK( IWRK ), IWORK( ND1+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(gdum)*D1112 . +C + CALL DLACPY( 'Full', ND1, NP2, D( 1, ND2+1 ), LDD, + $ DWORK( IW2 ), ND1 ) + CALL DSYTRS( 'U', ND1, NP2, DWORK( IW1 ), ND1, IWORK, + $ DWORK( IW2 ), ND1, INFO2 ) +C +C Compute D11HAT = -D1121*D1111'*inv(gdum)*D1112 - D1122 . +C + CALL DGEMM( 'T', 'N', ND2, NP2, ND1, ONE, D, LDD, + $ DWORK( IW2 ), ND1, ZERO, DWORK( IW3 ), ND2 ) + CALL DGEMM( 'N', 'N', M2, NP2, ND2, -ONE, D( ND1+1, 1 ), + $ LDD, DWORK( IW3 ), ND2, ONE, DWORK( ID11 ), M2 ) +C +C Compute D21HAT'*D21HAT = Inp2 - D1112'*inv(gdum)*D1112 . +C + CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, ND1, ONE, + $ -ONE, DWORK( ID21 ), NP2, D( 1, ND2+1 ), LDD, + $ DWORK( IW2 ), ND1, INFO2 ) +C + IW2 = IW1 + ND2*ND2 + IWRK = IW2 +C +C Compute gdum = gamma^2*Ind2 - D1111'*D1111 . +C + CALL DLASET( 'L', ND2, ND2, ZERO, GAMMA**2, DWORK( IW1 ), + $ ND2 ) + CALL DSYRK( 'L', 'T', ND2, ND1, -ONE, D, LDD, ONE, + $ DWORK( IW1 ), ND2 ) + ANORM = DLANSY( 'I', 'L', ND2, DWORK( IW1 ), ND2, + $ DWORK( IWRK ) ) + CALL DSYTRF( 'L', ND2, DWORK( IW1 ), ND2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) + CALL DSYCON( 'L', ND2, DWORK( IW1 ), ND2, IWORK, ANORM, + $ RCOND, DWORK( IWRK ), IWORK( ND2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(gdum)*D1121' . +C + CALL MA02AD( 'Full', M2, ND2, D( ND1+1, 1 ), LDD, + $ DWORK( IW2 ), ND2 ) + CALL DSYTRS( 'L', ND2, M2, DWORK( IW1 ), ND2, IWORK, + $ DWORK( IW2 ), ND2, INFO2 ) +C +C Compute D12HAT*D12HAT' = Im2 - D1121*inv(gdum)*D1121' . +C + CALL MB01RX( 'Left', 'Lower', 'NoTranspose', M2, ND2, ONE, + $ -ONE, DWORK( ID12 ), M2, D( ND1+1, 1 ), LDD, + $ DWORK( IW2 ), ND2, INFO2 ) + END IF + ELSE + IF( ND2.GT.0 ) THEN +C +C Compute D12HAT*D12HAT' = Im2 - D1121*D1121'/gamma^2 . +C + CALL DSYRK( 'L', 'N', M2, ND2, -ONE/GAMMA**2, D, LDD, ONE, + $ DWORK( ID12 ), M2 ) + END IF + END IF +C +C Compute D21HAT using Cholesky decomposition. +C + CALL DPOTRF( 'U', NP2, DWORK( ID21 ), NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C +C Compute D12HAT using Cholesky decomposition. +C + CALL DPOTRF( 'L', M2, DWORK( ID12 ), M2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C _ +C Compute Z = In - Y*X/gamma^2 and its LU factorization in AK . +C + IWRK = IW1 + CALL DLASET( 'Full', N, N, ZERO, ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, N, -ONE/GAMMA**2, Y, LDY, X, LDX, + $ ONE, AK, LDAK ) + ANORM = DLANGE( '1', N, N, AK, LDAK, DWORK( IWRK ) ) + CALL DGETRF( N, N, AK, LDAK, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL DGECON( '1', N, AK, LDAK, ANORM, RCOND, DWORK( IWRK ), + $ IWORK( N+1 ), INFO ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C + IWB = IW1 + IWC = IWB + N*NP2 + IW1 = IWC + ( M2 + NP2 )*N + IW2 = IW1 + N*M2 +C +C Compute C2' + F12' in BK . +C + DO 40 J = 1, N + DO 30 I = 1, NP2 + BK( J, I ) = C( NP1 + I, J ) + F( ND2 + I, J ) + 30 CONTINUE + 40 CONTINUE +C _ +C Compute the transpose of (C2 + F12)*Z , with Z = inv(Z) . +C + CALL DGETRS( 'Transpose', N, NP2, AK, LDAK, IWORK, BK, LDBK, + $ INFO2 ) +C +C Compute the transpose of F2*Z . +C + CALL MA02AD( 'Full', M2, N, F( M1+1, 1 ), LDF, DWORK( IW1 ), N ) + CALL DGETRS( 'Transpose', N, M2, AK, LDAK, IWORK, DWORK( IW1 ), N, + $ INFO2 ) +C +C Compute the transpose of C1HAT = F2*Z - D11HAT*(C2 + F12)*Z . +C + CALL DGEMM( 'N', 'T', N, M2, NP2, -ONE, BK, LDBK, DWORK( ID11 ), + $ M2, ONE, DWORK( IW1 ), N ) +C +C Compute CHAT . +C + CALL DGEMM( 'N', 'T', M2, N, M2, ONE, TU, LDTU, DWORK( IW1 ), N, + $ ZERO, DWORK( IWC ), M2+NP2 ) + CALL MA02AD( 'Full', N, NP2, BK, LDBK, DWORK( IWC+M2 ), M2+NP2 ) + CALL DTRMM( 'L', 'U', 'N', 'N', NP2, N, -ONE, DWORK( ID21 ), NP2, + $ DWORK( IWC+M2 ), M2+NP2 ) +C +C Compute B2 + H12 . +C + IJ = IW2 + DO 60 J = 1, M2 + DO 50 I = 1, N + DWORK( IJ ) = B( I, M1 + J ) + H( I, ND1 + J ) + IJ = IJ + 1 + 50 CONTINUE + 60 CONTINUE +C +C Compute A + HC in AK . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, H, LDH, C, LDC, ONE, AK, + $ LDAK ) +C +C Compute AHAT = A + HC + (B2 + H12)*C1HAT in AK . +C + CALL DGEMM( 'N', 'T', N, N, M2, ONE, DWORK( IW2 ), N, + $ DWORK( IW1 ), N, ONE, AK, LDAK ) +C +C Compute B1HAT = -H2 + (B2 + H12)*D11HAT in BK . +C + CALL DLACPY( 'Full', N, NP2, H( 1, NP1+1 ), LDH, BK, LDBK ) + CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, DWORK( IW2 ), N, + $ DWORK( ID11 ), M2, -ONE, BK, LDBK ) +C +C Compute the first block of BHAT, BHAT1 . +C + CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, + $ DWORK( IWB ), N ) +C +C Compute Tu*D11HAT . +C + CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DWORK( ID11 ), + $ M2, ZERO, DWORK( IW1 ), M2 ) +C +C Compute Tu*D11HAT*Ty in DK . +C + CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK( IW1 ), M2, TY, + $ LDTY, ZERO, DK, LDDK ) +C +C Compute P = Im2 + Tu*D11HAT*Ty*D22 and its condition. +C + IW2 = IW1 + M2*NP2 + IWRK = IW2 + M2*M2 + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) + CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK, + $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF + CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( M2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 2 + RETURN + END IF +C +C Find the controller matrix CK, CK = inv(P)*CHAT(1:M2,:) . +C + CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) + CALL DGETRS( 'NoTranspose', M2, N, DWORK( IW2 ), M2, IWORK, CK, + $ LDCK, INFO2 ) +C +C Find the controller matrices AK, BK, and DK, exploiting the +C special structure of the relations. +C +C Compute Q = Inp2 + D22*Tu*D11HAT*Ty and its LU factorization. +C + IW3 = IW2 + NP2*NP2 + IW4 = IW3 + NP2*M2 + IWRK = IW4 + NP2*NP2 + CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, M2, ONE, D( NP1+1, M1+1 ), LDD, + $ DK, LDDK, ONE, DWORK( IW2 ), NP2 ) + CALL DGETRF( NP2, NP2, DWORK( IW2 ), NP2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Compute A1 = inv(Q)*D22 and inv(Q) . +C + CALL DLACPY( 'Full', NP2, M2, D( NP1+1, M1+1 ), LDD, DWORK( IW3 ), + $ NP2 ) + CALL DGETRS( 'NoTranspose', NP2, M2, DWORK( IW2 ), NP2, IWORK, + $ DWORK( IW3 ), NP2, INFO2 ) + CALL DGETRI( NP2, DWORK( IW2 ), NP2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute A2 = ( inv(Ty) - inv(Q)*inv(Ty) - +C A1*Tu*D11HAT )*inv(D21HAT) . +C + CALL DLACPY( 'Full', NP2, NP2, TY, LDTY, DWORK( IW4 ), NP2 ) + CALL DGETRF( NP2, NP2, DWORK( IW4 ), NP2, IWORK, INFO2 ) + CALL DGETRI( NP2, DWORK( IW4 ), NP2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) +C + CALL DLACPY( 'Full', NP2, NP2, DWORK( IW4 ), NP2, DWORK( IWRK ), + $ NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, NP2, -ONE, DWORK( IW2), NP2, + $ DWORK( IWRK ), NP2, ONE, DWORK( IW4 ), NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, DWORK( IW3), NP2, + $ DWORK( IW1 ), M2, ONE, DWORK( IW4 ), NP2 ) + CALL DTRMM( 'R', 'U', 'N', 'N', NP2, NP2, ONE, DWORK( ID21 ), NP2, + $ DWORK( IW4 ), NP2 ) +C +C Compute [ A1 A2 ]*CHAT . +C + CALL DGEMM( 'N', 'N', NP2, N, M2+NP2, ONE, DWORK( IW3 ), NP2, + $ DWORK( IWC ), M2+NP2, ZERO, DWORK( IWRK ), NP2 ) +C +C Compute AK := AHAT - BHAT1*[ A1 A2 ]*CHAT . +C + CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, DWORK( IWB ), N, + $ DWORK( IWRK ), NP2, ONE, AK, LDAK ) +C +C Compute BK := BHAT1*inv(Q) . +C + CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, DWORK( IWB ), N, + $ DWORK( IW2 ), NP2, ZERO, BK, LDBK ) +C +C Compute DK := Tu*D11HAT*Ty*inv(Q) . +C + CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DK, LDDK, DWORK( IW2 ), + $ NP2, ZERO, DWORK( IW3 ), M2 ) + CALL DLACPY( 'Full', M2, NP2, DWORK( IW3 ), M2, DK, LDDK ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10RD *** + END diff --git a/modules/cacsd/src/slicot/sb10rd.lo b/modules/cacsd/src/slicot/sb10rd.lo new file mode 100755 index 000000000..88b0c4666 --- /dev/null +++ b/modules/cacsd/src/slicot/sb10rd.lo @@ -0,0 +1,12 @@ +# src/slicot/sb10rd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/sb10rd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/select.f b/modules/cacsd/src/slicot/select.f new file mode 100755 index 000000000..a7c629895 --- /dev/null +++ b/modules/cacsd/src/slicot/select.f @@ -0,0 +1,11 @@ + LOGICAL FUNCTION SELECT1( PAR1, PAR2 ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +C +C Void logical function for DGEES. +C + DOUBLE PRECISION PAR1, PAR2 +C + SELECT1 = .TRUE. + RETURN + END diff --git a/modules/cacsd/src/slicot/select.lo b/modules/cacsd/src/slicot/select.lo new file mode 100755 index 000000000..82db557f2 --- /dev/null +++ b/modules/cacsd/src/slicot/select.lo @@ -0,0 +1,12 @@ +# src/slicot/select.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/select.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/slicot_f/common_f2c.c b/modules/cacsd/src/slicot/slicot_f/common_f2c.c new file mode 100755 index 000000000..fdacf1d73 --- /dev/null +++ b/modules/cacsd/src/slicot/slicot_f/common_f2c.c @@ -0,0 +1,24 @@ +/* +* Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +* Copyright (C) 2010 - DIGITEO - Allan CORNET +* +* This file must be used under the terms of the CeCILL. +* This source file is licensed as described in the file COPYING, which +* you should have received as part of this distribution. The terms +* are also available at +* http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +* +*/ + +/* ONLY used by F2C with scilab_f2c.sln on Windows */ +/* this modification removes some warning about no defined or redefined COMMON */ +/* We force definition of COMMON only used in current dynamic library */ +/*--------------------------------------------------------------------------*/ +/* see fortran code for definition of this COMMON */ +#ifdef _MSC_VER +struct +{ + long int iero; +} ierinv_; +#endif +/*--------------------------------------------------------------------------*/ diff --git a/modules/cacsd/src/slicot/slicot_f/core_Import.def b/modules/cacsd/src/slicot/slicot_f/core_Import.def new file mode 100755 index 000000000..c8ac93fe3 --- /dev/null +++ b/modules/cacsd/src/slicot/slicot_f/core_Import.def @@ -0,0 +1,6 @@ + LIBRARY core.dll + + +EXPORTS + +; diff --git a/modules/cacsd/src/slicot/slicot_f/elementary_functions_f_Import.def b/modules/cacsd/src/slicot/slicot_f/elementary_functions_f_Import.def new file mode 100755 index 000000000..1dace11ab --- /dev/null +++ b/modules/cacsd/src/slicot/slicot_f/elementary_functions_f_Import.def @@ -0,0 +1,8 @@ + LIBRARY elementary_functions_f.dll + + +EXPORTS + +; +;elementary_functions_f +exch_
\ No newline at end of file diff --git a/modules/cacsd/src/slicot/slicot_f/linear_algebra_f_Import.def b/modules/cacsd/src/slicot/slicot_f/linear_algebra_f_Import.def new file mode 100755 index 000000000..7021e8799 --- /dev/null +++ b/modules/cacsd/src/slicot/slicot_f/linear_algebra_f_Import.def @@ -0,0 +1,12 @@ + LIBRARY linear_algebra_f.dll + + +EXPORTS + +; +;linear_algebra_f +sb02ow_ +sb02ox_ +sb02mw_ +sb02mv_ +voiddummy_ diff --git a/modules/cacsd/src/slicot/slicot_f/linpack_f_Import.def b/modules/cacsd/src/slicot/slicot_f/linpack_f_Import.def new file mode 100755 index 000000000..2a48d5d0a --- /dev/null +++ b/modules/cacsd/src/slicot/slicot_f/linpack_f_Import.def @@ -0,0 +1,10 @@ + LIBRARY linpack_f.dll + + +EXPORTS + +; +;linpack_f +dqrdc_ +dqrsm_ +hhdml_ diff --git a/modules/cacsd/src/slicot/slicot_f/slicot_f.rc b/modules/cacsd/src/slicot/slicot_f/slicot_f.rc new file mode 100755 index 000000000..8367394df --- /dev/null +++ b/modules/cacsd/src/slicot/slicot_f/slicot_f.rc @@ -0,0 +1,96 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +//#include "afxres.h" +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "slicot_f module" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "slicot_f module" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "slicot_f.dll" + VALUE "ProductName", "slicot_f module" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/cacsd/src/slicot/slicot_f/slicot_f.vfproj b/modules/cacsd/src/slicot/slicot_f/slicot_f.vfproj new file mode 100755 index 000000000..72fc52e31 --- /dev/null +++ b/modules/cacsd/src/slicot/slicot_f/slicot_f.vfproj @@ -0,0 +1,203 @@ +<?xml version="1.0" encoding="UTF-8"?> +<VisualStudioProject ProjectType="typeDynamicLibrary" ProjectCreator="Intel Fortran" Keyword="Dll" Version="11.0" ProjectIdGuid="{C4C3EA58-1C27-4EFB-A5BF-0DB24EC5F87A}"> + <Platforms> + <Platform Name="Win32"/> + <Platform Name="x64"/></Platforms> + <Configurations> + <Configuration Name="Debug|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="slicot_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib ../../../../../bin/blasplus.lib linear_algebra_f.lib core.lib linpack_f.lib elementary_functions_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)linear_algebra_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)linear_algebra_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL" Description="Build core.lib (dependencies)"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="slicot_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib ../../../../../bin/blasplus.lib linear_algebra_f.lib core.lib linpack_f.lib elementary_functions_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)linear_algebra_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)linear_algebra_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL" Description="Build core.lib (dependencies)"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Debug|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="slicot_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib ../../../../../bin/blasplus.lib linear_algebra_f.lib core.lib linpack_f.lib elementary_functions_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)linear_algebra_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)linear_algebra_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL" Description="Build core.lib (dependencies)"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="slicot_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib ../../../../../bin/blasplus.lib linear_algebra_f.lib core.lib linpack_f.lib elementary_functions_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)linear_algebra_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)linear_algebra_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL" Description="Build core.lib (dependencies)"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration></Configurations> + <Files> + <Filter Name="Header Files" Filter="fi;fd"/> + <Filter Name="Library Dependencies"> + <File RelativePath=".\core_import.def"/> + <File RelativePath=".\elementary_functions_f_Import.def"/> + <File RelativePath=".\linear_algebra_f_Import.def"/> + <File RelativePath=".\linpack_f_Import.def"/></Filter> + <Filter Name="Resource Files" Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"> + <File RelativePath=".\slicot_f.rc"/></Filter> + <Filter Name="Source Files" Filter="f90;for;f;fpp;ftn;def;odl;idl"> + <File RelativePath="..\ab01nd.f"/> + <File RelativePath="..\ab01od.f"/> + <File RelativePath="..\ab13md.f"/> + <File RelativePath="..\ereduc.f"/> + <File RelativePath="..\Ex-schur.f"/> + <File RelativePath="..\fstair.f"/> + <File RelativePath="..\ib01ad.f"/> + <File RelativePath="..\ib01bd.f"/> + <File RelativePath="..\ib01cd.f"/> + <File RelativePath="..\ib01md.f"/> + <File RelativePath="..\ib01my.f"/> + <File RelativePath="..\ib01nd.f"/> + <File RelativePath="..\ib01od.f"/> + <File RelativePath="..\ib01oy.f"/> + <File RelativePath="..\ib01pd.f"/> + <File RelativePath="..\ib01px.f"/> + <File RelativePath="..\ib01py.f"/> + <File RelativePath="..\ib01qd.f"/> + <File RelativePath="..\ib01rd.f"/> + <File RelativePath="..\inva.f"/> + <File RelativePath="..\ma02ad.f"/> + <File RelativePath="..\ma02ed.f"/> + <File RelativePath="..\ma02fd.f"/> + <File RelativePath="..\mb01pd.f"/> + <File RelativePath="..\mb01qd.f"/> + <File RelativePath="..\mb01rd.f"/> + <File RelativePath="..\mb01ru.f"/> + <File RelativePath="..\mb01rx.f"/> + <File RelativePath="..\mb01ry.f"/> + <File RelativePath="..\mb01sd.f"/> + <File RelativePath="..\mb01td.f"/> + <File RelativePath="..\mb01ud.f"/> + <File RelativePath="..\mb01vd.f"/> + <File RelativePath="..\mb02pd.f"/> + <File RelativePath="..\mb02qy.f"/> + <File RelativePath="..\mb02ud.f"/> + <File RelativePath="..\mb03od.f"/> + <File RelativePath="..\mb03oy.f"/> + <File RelativePath="..\mb03ud.f"/> + <File RelativePath="..\mb04id.f"/> + <File RelativePath="..\mb04iy.f"/> + <File RelativePath="..\mb04kd.f"/> + <File RelativePath="..\mb04nd.f"/> + <File RelativePath="..\mb04ny.f"/> + <File RelativePath="..\mb04od.f"/> + <File RelativePath="..\mb04oy.f"/> + <File RelativePath="..\polmc.f"/> + <File RelativePath="..\riccpack.f"/> + <File RelativePath="..\sb02mr.f"/> + <File RelativePath="..\sb02ms.f"/> + <File RelativePath="..\sb02mt.f"/> + <File RelativePath="..\sb02nd.f"/> + <File RelativePath="..\sb02od.f"/> + <File RelativePath="..\sb02ou.f"/> + <File RelativePath="..\sb02ov.f"/> + <File RelativePath="..\sb02oy.f"/> + <File RelativePath="..\sb02qd.f"/> + <File RelativePath="..\sb02rd.f"/> + <File RelativePath="..\sb02ru.f"/> + <File RelativePath="..\sb02sd.f"/> + <File RelativePath="..\sb03md.f"/> + <File RelativePath="..\sb03mv.f"/> + <File RelativePath="..\sb03mw.f"/> + <File RelativePath="..\sb03mx.f"/> + <File RelativePath="..\sb03my.f"/> + <File RelativePath="..\sb03od.f"/> + <File RelativePath="..\sb03or.f"/> + <File RelativePath="..\sb03ot.f"/> + <File RelativePath="..\sb03ou.f"/> + <File RelativePath="..\sb03ov.f"/> + <File RelativePath="..\sb03oy.f"/> + <File RelativePath="..\sb03qx.f"/> + <File RelativePath="..\sb03qy.f"/> + <File RelativePath="..\sb03sx.f"/> + <File RelativePath="..\sb03sy.f"/> + <File RelativePath="..\sb04md.f"/> + <File RelativePath="..\sb04mr.f"/> + <File RelativePath="..\sb04mu.f"/> + <File RelativePath="..\sb04mw.f"/> + <File RelativePath="..\sb04my.f"/> + <File RelativePath="..\sb04nd.f"/> + <File RelativePath="..\sb04nv.f"/> + <File RelativePath="..\sb04nw.f"/> + <File RelativePath="..\sb04nx.f"/> + <File RelativePath="..\sb04ny.f"/> + <File RelativePath="..\sb04pd.f"/> + <File RelativePath="..\sb04px.f"/> + <File RelativePath="..\sb04py.f"/> + <File RelativePath="..\sb04qd.f"/> + <File RelativePath="..\sb04qr.f"/> + <File RelativePath="..\sb04qu.f"/> + <File RelativePath="..\sb04qy.f"/> + <File RelativePath="..\sb04rd.f"/> + <File RelativePath="..\sb04rv.f"/> + <File RelativePath="..\sb04rw.f"/> + <File RelativePath="..\sb04rx.f"/> + <File RelativePath="..\sb04ry.f"/> + <File RelativePath="..\sb10dd.f"/> + <File RelativePath="..\sb10fd.f"/> + <File RelativePath="..\sb10pd.f"/> + <File RelativePath="..\sb10qd.f"/> + <File RelativePath="..\sb10rd.f"/> + <File RelativePath="..\select.f"/> + <File RelativePath="..\ssxmc.f"/> + <File RelativePath="..\tb01wd.f"/> + <File RelativePath="..\ZB03OD.f"/></Filter></Files> + <Globals/></VisualStudioProject> diff --git a/modules/cacsd/src/slicot/slicot_f/slicot_f2c.vcxproj b/modules/cacsd/src/slicot/slicot_f/slicot_f2c.vcxproj new file mode 100755 index 000000000..981e21086 --- /dev/null +++ b/modules/cacsd/src/slicot/slicot_f/slicot_f2c.vcxproj @@ -0,0 +1,491 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectName>slicot_f</ProjectName> + <ProjectGuid>{C4C3EA58-1C27-4EFB-A5BF-0DB24EC5F87A}</ProjectGuid> + <RootNamespace>slicot_f2c</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + <Import Project="..\..\..\..\..\Visual-Studio-settings\f2c.props" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</LinkIncremental> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <PreBuildEvent> + <Message>Build linear_algebra_f.lib (dependencies)</Message> + <Command>lib /DEF:"$(ProjectDir)linear_algebra_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linear_algebra_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;SLICOT_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>linear_algebra_f.lib;core.lib;elementary_functions_f.lib;linpack_f.lib;../../../../../bin/blasplus.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>slicot_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <PreBuildEvent> + <Message>Build linear_algebra_f.lib (dependencies)</Message> + <Command>lib /DEF:"$(ProjectDir)linear_algebra_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linear_algebra_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;SLICOT_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>linear_algebra_f.lib;core.lib;elementary_functions_f.lib;linpack_f.lib;../../../../../bin/blasplus.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>slicot_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <PreBuildEvent> + <Message>Build linear_algebra_f.lib (dependencies)</Message> + <Command>lib /DEF:"$(ProjectDir)linear_algebra_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linear_algebra_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;SLICOT_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>linear_algebra_f.lib;core.lib;elementary_functions_f.lib;linpack_f.lib;../../../../../bin/blasplus.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>slicot_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <PreBuildEvent> + <Message>Build linear_algebra_f.lib (dependencies)</Message> + <Command>lib /DEF:"$(ProjectDir)linear_algebra_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linear_algebra_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;SLICOT_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>linear_algebra_f.lib;core.lib;elementary_functions_f.lib;linpack_f.lib;../../../../../bin/blasplus.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>slicot_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="..\ab01nd.c" /> + <ClCompile Include="..\ab01od.c" /> + <ClCompile Include="..\ab13md.c" /> + <ClCompile Include="common_f2c.c" /> + <ClCompile Include="..\ereduc.c" /> + <ClCompile Include="..\Ex-schur.c" /> + <ClCompile Include="..\fstair.c" /> + <ClCompile Include="..\ib01ad.c" /> + <ClCompile Include="..\ib01bd.c" /> + <ClCompile Include="..\ib01cd.c" /> + <ClCompile Include="..\ib01md.c" /> + <ClCompile Include="..\ib01my.c" /> + <ClCompile Include="..\ib01nd.c" /> + <ClCompile Include="..\ib01od.c" /> + <ClCompile Include="..\ib01oy.c" /> + <ClCompile Include="..\ib01pd.c" /> + <ClCompile Include="..\ib01px.c" /> + <ClCompile Include="..\ib01py.c" /> + <ClCompile Include="..\ib01qd.c" /> + <ClCompile Include="..\ib01rd.c" /> + <ClCompile Include="..\inva.c" /> + <ClCompile Include="..\ma02ad.c" /> + <ClCompile Include="..\ma02ed.c" /> + <ClCompile Include="..\ma02fd.c" /> + <ClCompile Include="..\mb01pd.c" /> + <ClCompile Include="..\mb01qd.c" /> + <ClCompile Include="..\mb01rd.c" /> + <ClCompile Include="..\mb01ru.c" /> + <ClCompile Include="..\mb01rx.c" /> + <ClCompile Include="..\mb01ry.c" /> + <ClCompile Include="..\mb01sd.c" /> + <ClCompile Include="..\mb01td.c" /> + <ClCompile Include="..\mb01ud.c" /> + <ClCompile Include="..\mb01vd.c" /> + <ClCompile Include="..\mb02pd.c" /> + <ClCompile Include="..\mb02qy.c" /> + <ClCompile Include="..\mb02ud.c" /> + <ClCompile Include="..\mb03od.c" /> + <ClCompile Include="..\mb03oy.c" /> + <ClCompile Include="..\mb03ud.c" /> + <ClCompile Include="..\mb04id.c" /> + <ClCompile Include="..\mb04iy.c" /> + <ClCompile Include="..\mb04kd.c" /> + <ClCompile Include="..\mb04nd.c" /> + <ClCompile Include="..\mb04ny.c" /> + <ClCompile Include="..\mb04od.c" /> + <ClCompile Include="..\mb04oy.c" /> + <ClCompile Include="..\polmc.c" /> + <ClCompile Include="..\riccpack.c" /> + <ClCompile Include="..\sb02mr.c" /> + <ClCompile Include="..\sb02ms.c" /> + <ClCompile Include="..\sb02mt.c" /> + <ClCompile Include="..\sb02nd.c" /> + <ClCompile Include="..\sb02od.c" /> + <ClCompile Include="..\sb02ou.c" /> + <ClCompile Include="..\sb02ov.c" /> + <ClCompile Include="..\sb02oy.c" /> + <ClCompile Include="..\sb02qd.c" /> + <ClCompile Include="..\sb02rd.c" /> + <ClCompile Include="..\sb02ru.c" /> + <ClCompile Include="..\sb02sd.c" /> + <ClCompile Include="..\sb03md.c" /> + <ClCompile Include="..\sb03mv.c" /> + <ClCompile Include="..\sb03mw.c" /> + <ClCompile Include="..\sb03mx.c" /> + <ClCompile Include="..\sb03my.c" /> + <ClCompile Include="..\sb03od.c" /> + <ClCompile Include="..\sb03or.c" /> + <ClCompile Include="..\sb03ot.c" /> + <ClCompile Include="..\sb03ou.c" /> + <ClCompile Include="..\sb03ov.c" /> + <ClCompile Include="..\sb03oy.c" /> + <ClCompile Include="..\sb03qx.c" /> + <ClCompile Include="..\sb03qy.c" /> + <ClCompile Include="..\sb03sx.c" /> + <ClCompile Include="..\sb03sy.c" /> + <ClCompile Include="..\sb04md.c" /> + <ClCompile Include="..\sb04mr.c" /> + <ClCompile Include="..\sb04mu.c" /> + <ClCompile Include="..\sb04mw.c" /> + <ClCompile Include="..\sb04my.c" /> + <ClCompile Include="..\sb04nd.c" /> + <ClCompile Include="..\sb04nv.c" /> + <ClCompile Include="..\sb04nw.c" /> + <ClCompile Include="..\sb04nx.c" /> + <ClCompile Include="..\sb04ny.c" /> + <ClCompile Include="..\sb04pd.c" /> + <ClCompile Include="..\sb04px.c" /> + <ClCompile Include="..\sb04py.c" /> + <ClCompile Include="..\sb04qd.c" /> + <ClCompile Include="..\sb04qr.c" /> + <ClCompile Include="..\sb04qu.c" /> + <ClCompile Include="..\sb04qy.c" /> + <ClCompile Include="..\sb04rd.c" /> + <ClCompile Include="..\sb04rv.c" /> + <ClCompile Include="..\sb04rw.c" /> + <ClCompile Include="..\sb04rx.c" /> + <ClCompile Include="..\sb04ry.c" /> + <ClCompile Include="..\sb10dd.c" /> + <ClCompile Include="..\sb10fd.c" /> + <ClCompile Include="..\sb10pd.c" /> + <ClCompile Include="..\sb10qd.c" /> + <ClCompile Include="..\sb10rd.c" /> + <ClCompile Include="..\select.c" /> + <ClCompile Include="..\ssxmc.c" /> + <ClCompile Include="..\tb01wd.c" /> + <ClCompile Include="..\ZB03OD.c" /> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="..\ab01nd.f" /> + <f2c_rule Include="..\ab01od.f" /> + <f2c_rule Include="..\ab13md.f" /> + <f2c_rule Include="..\ereduc.f" /> + <f2c_rule Include="..\Ex-schur.f" /> + <f2c_rule Include="..\fstair.f" /> + <f2c_rule Include="..\ib01ad.f" /> + <f2c_rule Include="..\ib01bd.f" /> + <f2c_rule Include="..\ib01cd.f" /> + <f2c_rule Include="..\ib01md.f" /> + <f2c_rule Include="..\ib01my.f" /> + <f2c_rule Include="..\ib01nd.f" /> + <f2c_rule Include="..\ib01od.f" /> + <f2c_rule Include="..\ib01oy.f" /> + <f2c_rule Include="..\ib01pd.f" /> + <f2c_rule Include="..\ib01px.f" /> + <f2c_rule Include="..\ib01py.f" /> + <f2c_rule Include="..\ib01qd.f" /> + <f2c_rule Include="..\ib01rd.f" /> + <f2c_rule Include="..\inva.f" /> + <f2c_rule Include="..\ma02ad.f" /> + <f2c_rule Include="..\ma02ed.f" /> + <f2c_rule Include="..\ma02fd.f" /> + <f2c_rule Include="..\mb01pd.f" /> + <f2c_rule Include="..\mb01qd.f" /> + <f2c_rule Include="..\mb01rd.f" /> + <f2c_rule Include="..\mb01ru.f" /> + <f2c_rule Include="..\mb01rx.f" /> + <f2c_rule Include="..\mb01ry.f" /> + <f2c_rule Include="..\mb01sd.f" /> + <f2c_rule Include="..\mb01td.f" /> + <f2c_rule Include="..\mb01ud.f" /> + <f2c_rule Include="..\mb01vd.f" /> + <f2c_rule Include="..\mb02pd.f" /> + <f2c_rule Include="..\mb02qy.f" /> + <f2c_rule Include="..\mb02ud.f" /> + <f2c_rule Include="..\mb03od.f" /> + <f2c_rule Include="..\mb03oy.f" /> + <f2c_rule Include="..\mb03ud.f" /> + <f2c_rule Include="..\mb04id.f" /> + <f2c_rule Include="..\mb04iy.f" /> + <f2c_rule Include="..\mb04kd.f" /> + <f2c_rule Include="..\mb04nd.f" /> + <f2c_rule Include="..\mb04ny.f" /> + <f2c_rule Include="..\mb04od.f" /> + <f2c_rule Include="..\mb04oy.f" /> + <f2c_rule Include="..\polmc.f" /> + <f2c_rule Include="..\riccpack.f" /> + <f2c_rule Include="..\sb02mr.f" /> + <f2c_rule Include="..\sb02ms.f" /> + <f2c_rule Include="..\sb02mt.f" /> + <f2c_rule Include="..\sb02nd.f" /> + <f2c_rule Include="..\sb02od.f" /> + <f2c_rule Include="..\sb02ou.f" /> + <f2c_rule Include="..\sb02ov.f" /> + <f2c_rule Include="..\sb02oy.f" /> + <f2c_rule Include="..\sb02qd.f" /> + <f2c_rule Include="..\sb02rd.f" /> + <f2c_rule Include="..\sb02ru.f" /> + <f2c_rule Include="..\sb02sd.f" /> + <f2c_rule Include="..\sb03md.f" /> + <f2c_rule Include="..\sb03mv.f" /> + <f2c_rule Include="..\sb03mw.f" /> + <f2c_rule Include="..\sb03mx.f" /> + <f2c_rule Include="..\sb03my.f" /> + <f2c_rule Include="..\sb03od.f" /> + <f2c_rule Include="..\sb03or.f" /> + <f2c_rule Include="..\sb03ot.f" /> + <f2c_rule Include="..\sb03ou.f" /> + <f2c_rule Include="..\sb03ov.f" /> + <f2c_rule Include="..\sb03oy.f" /> + <f2c_rule Include="..\sb03qx.f" /> + <f2c_rule Include="..\sb03qy.f" /> + <f2c_rule Include="..\sb03sx.f" /> + <f2c_rule Include="..\sb03sy.f" /> + <f2c_rule Include="..\sb04md.f" /> + <f2c_rule Include="..\sb04mr.f" /> + <f2c_rule Include="..\sb04mu.f" /> + <f2c_rule Include="..\sb04mw.f" /> + <f2c_rule Include="..\sb04my.f" /> + <f2c_rule Include="..\sb04nd.f" /> + <f2c_rule Include="..\sb04nv.f" /> + <f2c_rule Include="..\sb04nw.f" /> + <f2c_rule Include="..\sb04nx.f" /> + <f2c_rule Include="..\sb04ny.f" /> + <f2c_rule Include="..\sb04pd.f" /> + <f2c_rule Include="..\sb04px.f" /> + <f2c_rule Include="..\sb04py.f" /> + <f2c_rule Include="..\sb04qd.f" /> + <f2c_rule Include="..\sb04qr.f" /> + <f2c_rule Include="..\sb04qu.f" /> + <f2c_rule Include="..\sb04qy.f" /> + <f2c_rule Include="..\sb04rd.f" /> + <f2c_rule Include="..\sb04rv.f" /> + <f2c_rule Include="..\sb04rw.f" /> + <f2c_rule Include="..\sb04rx.f" /> + <f2c_rule Include="..\sb04ry.f" /> + <f2c_rule Include="..\sb10dd.f" /> + <f2c_rule Include="..\sb10fd.f" /> + <f2c_rule Include="..\sb10pd.f" /> + <f2c_rule Include="..\sb10qd.f" /> + <f2c_rule Include="..\sb10rd.f" /> + <f2c_rule Include="..\select.f" /> + <f2c_rule Include="..\ssxmc.f" /> + <f2c_rule Include="..\tb01wd.f" /> + <f2c_rule Include="..\ZB03OD.f" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <ItemGroup> + <None Include="elementary_functions_f_Import.def" /> + <None Include="core_import.def" /> + <None Include="linear_algebra_f_Import.def" /> + <None Include="linpack_f_Import.def" /> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + <Import Project="..\..\..\..\..\Visual-Studio-settings\f2c.targets" /> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/cacsd/src/slicot/slicot_f/slicot_f2c.vcxproj.filters b/modules/cacsd/src/slicot/slicot_f/slicot_f2c.vcxproj.filters new file mode 100755 index 000000000..1eaded9c6 --- /dev/null +++ b/modules/cacsd/src/slicot/slicot_f/slicot_f2c.vcxproj.filters @@ -0,0 +1,680 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{4FC737F1-C7A5-4376-A066-2A32D752A2FF}</UniqueIdentifier> + <Extensions>cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{93995380-89BD-4b04-88EB-625FBE52EBFB}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl;inc;xsd</Extensions> + </Filter> + <Filter Include="Resource Files"> + <UniqueIdentifier>{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}</UniqueIdentifier> + <Extensions>rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx;tiff;tif;png;wav</Extensions> + </Filter> + <Filter Include="Fortran Files"> + <UniqueIdentifier>{c9fb7816-1618-4c01-bbee-f83f35b96745}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies"> + <UniqueIdentifier>{6044bd58-b658-4307-ad0b-ca5764e59a89}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="..\ab01nd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ab01od.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ab13md.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="common_f2c.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ereduc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\Ex-schur.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\fstair.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01ad.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01bd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01cd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01md.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01my.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01nd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01od.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01oy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01pd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01px.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01py.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01qd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ib01rd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\inva.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ma02ad.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ma02ed.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ma02fd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb01pd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb01qd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb01rd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb01ru.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb01rx.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb01ry.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb01sd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb01td.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb01ud.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb01vd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb02pd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb02qy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb02ud.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb03od.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb03oy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb03ud.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb04id.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb04iy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb04kd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb04nd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb04ny.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb04od.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\mb04oy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\polmc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\riccpack.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02mr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02ms.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02mt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02nd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02od.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02ou.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02ov.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02oy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02qd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02rd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02ru.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb02sd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03md.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03mv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03mw.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03mx.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03my.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03od.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03or.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03ot.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03ou.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03ov.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03oy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03qx.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03qy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03sx.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb03sy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04md.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04mr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04mu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04mw.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04my.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04nd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04nv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04nw.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04nx.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04ny.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04pd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04px.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04py.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04qd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04qr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04qu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04qy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04rd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04rv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04rw.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04rx.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb04ry.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb10dd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb10fd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb10pd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb10qd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\sb10rd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\select.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ssxmc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\tb01wd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ZB03OD.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="..\ab01nd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ab01od.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ab13md.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ereduc.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\Ex-schur.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\fstair.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01ad.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01bd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01cd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01md.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01my.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01nd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01od.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01oy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01pd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01px.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01py.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01qd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ib01rd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\inva.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ma02ad.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ma02ed.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ma02fd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb01pd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb01qd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb01rd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb01ru.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb01rx.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb01ry.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb01sd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb01td.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb01ud.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb01vd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb02pd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb02qy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb02ud.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb03od.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb03oy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb03ud.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb04id.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb04iy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb04kd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb04nd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb04ny.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb04od.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\mb04oy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\polmc.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\riccpack.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02mr.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02ms.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02mt.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02nd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02od.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02ou.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02ov.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02oy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02qd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02rd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02ru.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb02sd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03md.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03mv.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03mw.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03mx.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03my.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03od.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03or.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03ot.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03ou.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03ov.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03oy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03qx.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03qy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03sx.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb03sy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04md.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04mr.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04mu.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04mw.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04my.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04nd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04nv.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04nw.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04nx.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04ny.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04pd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04px.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04py.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04qd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04qr.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04qu.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04qy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04rd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04rv.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04rw.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04rx.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb04ry.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb10dd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb10fd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb10pd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb10qd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\sb10rd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\select.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ssxmc.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\tb01wd.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ZB03OD.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + </ItemGroup> + <ItemGroup> + <None Include="core_import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="linear_algebra_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="elementary_functions_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="linpack_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/cacsd/src/slicot/ssxmc.f b/modules/cacsd/src/slicot/ssxmc.f new file mode 100755 index 000000000..2336ddd0d --- /dev/null +++ b/modules/cacsd/src/slicot/ssxmc.f @@ -0,0 +1,306 @@ + subroutine ssxmc(n,m,a,na,b,ncont,indcon,nblk,z, + 1 wrka,wrk1,wrk2,iwrk,tol,mode) +c! calling sequence +c subroutine ssxmc(n,m,a,na,b,ncont,indcon,nblk,z, +c 1 wrka,wrk1,wrk2,iwrk,tol,mode) +c +c integer n,m,na,ncont,indcon,nblk(n),iwrk(m),mode +c +c real*8 a(na,n),b(na,m),z(na,n),wrka(n,m) +c real*8 wrk1(m),wrk2(m),tol +c +c arguments in +c +c n integer +c -the order of original state-space representation; +c declared first dimension of nblk,wrka; declared +c second dimension of a (and z, if mode .ne. 0) +c +c m integer +c -the number of system inputs; declared first dimension +c of iwrk,wrk1,wrk2; declared second dimension of b,wrka +c +c a double precision(n,n) +c -the original state dynamics matrix. note that this +c matrix is overwritten here +c +c na integer +c -the declared first dimension of a,b (and z, if +c mode .ne. 0). note that na .ge. n +c +c b double precision(n,m) +c -the original input/state matrix. note that this +c matrix is overwritten here +c +c tol double precision +c -if greater than the machine precision, tol is used +c as zero tolerance in rank determination when trans- +c forming (a,b,c): otherwise (eg tol = 0.0d+0), the +c machine precision is used +c +c mode integer +c -mode = 0 if accumulation of the orthogonal trans- +c formation z is not required, and non-zero if this +c matrix is required +c +c arguments out +c +c a double precision(ncont,ncont) +c -the upper block hessenberg state dynamics matrix of +c a controllable realization for the original system +c +c b double precision(ncont,m) +c -the transformed input/state matrix +c +c ncont integer +c -the order of controllable state-space representation +c +c indcon integer +c -the controllability index of transformed +c system representation +c +c nblk integer(indcon) +c -the dimensions of the diagonal blocks of the trans- +c formed a +c +c z double precision(n,n) +c -the orthogonal similarity transformation which +c reduces the given system to orthogonal canonical +c form. note that, if mode .eq. 0, z is not referenced +c and so can be a scalar dummy variable +c +c!working space +c +c wrka double precision(n,m) +c +c wrk1 double precision(m) +c +c wrk2 double precision(m) +c +c iwrk integer(m) +c +c!purpose +c +c to reduce the linear time-invariant multi-input system +c +c dx/dt = a * x + b * u, +c +c where a and b are (n x n) and (n x m) matrices respectively, +c to orthogonal canonical form using (and optionally accum- +c ulating) orthogonal similarity transformations. +c +c!method +c +c b is first qr-decomposed and the appropriate orthogonal +c similarity transformation applied to a. leaving the first +c rank(b) states unchanged, the resulting lower left block +c of a is now itself qr-decomposed and this new orthogonal +c similarity transformation applied. continuing in this +c manner, a completely controllable state-space pair (acont, +c bcont) is found for the given (a,b), where acont is upper +c block hessenberg with each sub-diagonal block of full row +c rank, and bcont is zero apart from its (independent) first +c rank(b) rows. note finally that the system controllability +c indices are easily calculable from the dimensions of the +c blocks of acont. +c +c!reference +c +c konstantinov, m.m., petkov, p.hr. and christov, n.d. +c "orthogonal invariants and canonical forms for linear +c controllable systems" +c proc. ifac 8th world congress, 1981. +c +c!auxiliary routines +c +c dqrdc (linpack) +c +c!originator +c +c p.hr.petkov, higher institute of mechanical and +c electrical engineering, sofia, bulgaria, april 1981 +C Copyright SLICOT +c +c!comments +c +c none +c +c!user-supplied routines +c +c none +c! +c******************************************************************* +c +c + integer nblk(n),iwrk(m) +c + double precision a(na,n),b(na,m),z(na,n),tol + double precision wrka(n,m),wrk1(m),wrk2(m) +c +c local variables: +c +c + double precision abnorm,temp,thrtol +c +c common /smprec/eps +c +c common block smprec is shared with routine ddata which provides +c a value for eps, a machine-dependent parameter which specifies +c the relative precision of drealing-point arithmetic +c +c +c call ddata +c + abnorm = 0.0d+0 + ist = 0 + ncont = 0 + indcon = 0 + ni = 0 + nb = n + mb = m +c +c use the larger of tol, eps in rank determination +c +c toleps = dble(n * n) * max(tol,eps) +c + if (mode .eq. 0) go to 30 +c +c initialize z to identity matrix +c + do 20 i = 1, n +c + do 10 j = 1, n + 10 z(i,j) = 0.0d+0 +c + z(i,i) = 1.0d+0 + 20 continue +c + 30 do 50 i = 1, n +c + do 40 j = 1, m + wrka(i,j) = b(i,j) + b(i,j) = 0.0d+0 + 40 continue +c + 50 continue +c + 60 ist = ist + 1 +c +c qr decomposition with column pivoting +c + do 70 j = 1, mb + 70 iwrk(j) = 0 +c + call dqrdc(wrka,n,nb,mb,wrk1,iwrk,wrk2,1) +c + irnk = 0 + mm = min(nb,mb) + if (abs(wrka(1,1)) .gt. abnorm) abnorm = abs(wrka(1,1)) +c thresh = toleps * abnorm +c +c rank determination +c + thrtol=tol*abnorm*dble(n*n) + do 100 i = 1,mm + temp=abs(wrka(i,i)) + if(temp.gt.thrtol.and.1.0d+0+temp.gt.1.0d+0) irnk = i + 100 continue +c + if (irnk .eq. 0) go to 360 + nj = ni + ni = ncont + ncont = ncont + irnk + indcon = indcon + 1 + nblk(indcon) = irnk + lu = min(irnk,nb-1) + if (lu .eq. 0) go to 200 +c +c premultiply appropriate row block of a by qtrans +c + call hhdml(lu,n,n,ni,ni,nb,nb,wrka,n,wrk1,a,na,11,ierr) +c +c postmultiply appropriate column block of a by q +c + call hhdml(lu,n,n,0,ni,n,nb,wrka,n,wrk1,a,na,00,ierr) +c +c if required, accumulate transformations +c + if (mode .ne. 0) call hhdml(lu,n,n,0,ni,n,nb,wrka,n,wrk1,z,na, + 1 00,ierr) +c + 200 if (irnk .lt. 2) go to 230 +c + do 220 i = 2, irnk + im1 = i - 1 +c + do 210 j = 1, im1 + 210 wrka(i,j) = 0.0d+0 +c + 220 continue +c +c backward permutation of the columns +c + 230 do 270 j = 1, mb + if (iwrk(j) .lt. 0) go to 270 + k = iwrk(j) + iwrk(j) = -k + 240 continue + if (k .eq. j) go to 260 +c + do 250 i = 1, irnk + temp = wrka(i,k) + wrka(i,k) = wrka(i,j) + wrka(i,j) = temp + 250 continue +c + iwrk(k) = -iwrk(k) + k = -iwrk(k) + go to 240 + 260 continue + 270 continue +c + if (ist .gt. 1) go to 300 +c +c form b +c + do 290 i = 1, irnk +c + do 280 j = 1, m + 280 b(i,j) = wrka(i,j) +c + 290 continue +c + go to 330 +c +c form a +c + 300 do 320 i = 1, irnk + ia = ni + i +c + do 310 j = 1, mb + ja = nj + j + 310 a(ia,ja) = wrka(i,j) +c + 320 continue +c + 330 if (irnk .eq. nb) go to 360 +c + mb = irnk + nb = nb - irnk +c + do 350 i = 1, nb + ia = ncont + i +c + do 340 j = 1, mb + ja = ni + j + wrka(i,j) = a(ia,ja) + a(ia,ja) = 0.0d+0 + 340 continue +c + 350 continue + go to 60 +c + 360 continue +c + return + end diff --git a/modules/cacsd/src/slicot/ssxmc.lo b/modules/cacsd/src/slicot/ssxmc.lo new file mode 100755 index 000000000..908f6205b --- /dev/null +++ b/modules/cacsd/src/slicot/ssxmc.lo @@ -0,0 +1,12 @@ +# src/slicot/ssxmc.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ssxmc.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/cacsd/src/slicot/tb01wd.f b/modules/cacsd/src/slicot/tb01wd.f new file mode 100755 index 000000000..213d76ddf --- /dev/null +++ b/modules/cacsd/src/slicot/tb01wd.f @@ -0,0 +1,243 @@ + SUBROUTINE TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU, + $ WR, WI, DWORK, LDWORK, INFO ) +C +C RELEASE 4.0, WGS COPYRIGHT 1999. +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 SELECT1 + EXTERNAL SELECT1 +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', SELECT1, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + WRKOPT = DWORK( 1 ) + IF( INFO.NE.0 ) + $ RETURN +C +C Apply the transformation: B <-- U'*B. +C + IF( LDWORK.LT.N*M ) THEN +C +C Not enough working space for using DGEMM. +C + DO 10 I = 1, M + CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, + $ B(1,I), 1 ) + 10 CONTINUE +C + ELSE + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, + $ DWORK, N, ZERO, B, LDB ) + WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) + END IF +C +C Apply the transformation: C <-- C*U. +C + IF( LDWORK.LT.N*P ) THEN +C +C Not enough working space for using DGEMM. +C + DO 20 I = 1, P + CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, + $ C(I,1), LDC ) + 20 CONTINUE +C + ELSE + LDWP = MAX( 1, P ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) + CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, + $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) + WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) + END IF +C + DWORK( 1 ) = WRKOPT +C + RETURN +C *** Last line of TB01WD *** + END diff --git a/modules/cacsd/src/slicot/tb01wd.lo b/modules/cacsd/src/slicot/tb01wd.lo new file mode 100755 index 000000000..9a730e620 --- /dev/null +++ b/modules/cacsd/src/slicot/tb01wd.lo @@ -0,0 +1,12 @@ +# src/slicot/tb01wd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/tb01wd.o' + +# Name of the non-PIC object +non_pic_object=none + |