floraachy
/
OpenBLAS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Refs #324. Upgrade LAPACK to 3.5.0 version.

This commit is contained in:
Zhang Xianyi 2013-12-09 16:50:02 +08:00
parent ea74f331f4
commit 0f6e79f918
311 changed files with 57647 additions and 5515 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
exports/gensymbol
View File

@ -213,7 +213,8 @@
stfttr, stpttf, stpttr, strttf, strttp,
sgejsv, sgesvj, sgsvj0, sgsvj1,
sgeequb, ssyequb, spoequb, sgbequb,
sbbcsd, slapmr, sorbdb, sorcsd,
sbbcsd, slapmr, sorbdb, sorbdb1, sorbdb2, sorbdb3, sorbdb4,
sorbdb5, sorbdb6, sorcsd, sorcsd2by1,
sgeqrt, sgeqrt2, sgeqrt3, sgemqrt,
stpqrt, stpqrt2, stpmqrt, stprfb,
@ -288,7 +289,8 @@
chfrk, ctfttp, clanhf, cpftrf, cpftri, cpftrs, ctfsm, ctftri,
ctfttr, ctpttf, ctpttr, ctrttf, ctrttp,
cgeequb, cgbequb, csyequb, cpoequb, cheequb,
cbbcsd, clapmr, cunbdb, cuncsd,
cbbcsd, clapmr, cunbdb, cunbdb1, cunbdb2, cunbdb3, cunbdb4,
cunbdb5, cunbdb6, cuncsd, cuncsd2by1,
cgeqrt, cgeqrt2, cgeqrt3, cgemqrt,
ctpqrt, ctpqrt2, ctpmqrt, ctprfb,
@ -360,7 +362,8 @@
dtfttr, dtpttf, dtpttr, dtrttf, dtrttp,
dgejsv, dgesvj, dgsvj0, dgsvj1,
dgeequb, dsyequb, dpoequb, dgbequb,
dbbcsd, dlapmr, dorbdb, dorcsd,
dbbcsd, dlapmr, dorbdb, dorbdb1, dorbdb2, dorbdb3, dorbdb4,
dorbdb5, dorbdb6, dorcsd, dorcsd2by1,
dgeqrt, dgeqrt2, dgeqrt3, dgemqrt,
dtpqrt, dtpqrt2, dtpmqrt, dtprfb,
@ -433,7 +436,8 @@
zhfrk, ztfttp, zlanhf, zpftrf, zpftri, zpftrs, ztfsm, ztftri,
ztfttr, ztpttf, ztpttr, ztrttf, ztrttp,
zgeequb, zgbequb, zsyequb, zpoequb, zheequb,
zbbcsd, zlapmr, zunbdb, zuncsd,
zbbcsd, zlapmr, zunbdb, zunbdb1, zunbdb2, zunbdb3, zunbdb4,
zunbdb5, zunbdb6, zuncsd, zuncsd2by1,
zgeqrt, zgeqrt2, zgeqrt3, zgemqrt,
ztpqrt, ztpqrt2, ztpmqrt, ztprfb,
);
@ -603,7 +607,7 @@
lapack_make_complex_float,
lapack_make_complex_double,
# @(SRC_OBJ) from `lapack-3.4.1/lapacke/src/Makefile`
# @(SRC_OBJ) from `lapack-3.5.0/lapacke/src/Makefile`
LAPACKE_cbbcsd,
LAPACKE_cbbcsd_work,
LAPACKE_cbdsqr,
@ -836,6 +840,10 @@
LAPACKE_chseqr_work,
LAPACKE_clacgv,
LAPACKE_clacgv_work,
LAPACKE_clacn2,
LAPACKE_clacn2_work,
LAPACKE_clacp2,
LAPACKE_clacp2_work,
LAPACKE_clacpy,
LAPACKE_clacpy_work,
LAPACKE_clag2z,
@ -971,6 +979,8 @@
LAPACKE_csyrfs,
LAPACKE_csyrfs_work,
LAPACKE_csysv,
LAPACKE_csysv_rook,
LAPACKE_csysv_rook_work,
LAPACKE_csysv_work,
LAPACKE_csysvx,
LAPACKE_csysvx_work,
@ -1244,6 +1254,8 @@
LAPACKE_dhsein_work,
LAPACKE_dhseqr,
LAPACKE_dhseqr_work,
LAPACKE_dlacn2,
LAPACKE_dlacn2_work,
LAPACKE_dlacpy,
LAPACKE_dlacpy_work,
LAPACKE_dlag2s,
@ -1493,6 +1505,8 @@
LAPACKE_dsyrfs,
LAPACKE_dsyrfs_work,
LAPACKE_dsysv,
LAPACKE_dsysv_rook,
LAPACKE_dsysv_rook_work,
LAPACKE_dsysv_work,
LAPACKE_dsysvx,
LAPACKE_dsysvx_work,
@ -1730,6 +1744,8 @@
LAPACKE_shsein_work,
LAPACKE_shseqr,
LAPACKE_shseqr_work,
LAPACKE_slacn2,
LAPACKE_slacn2_work,
LAPACKE_slacpy,
LAPACKE_slacpy_work,
LAPACKE_slag2d,
@ -1975,6 +1991,8 @@
LAPACKE_ssyrfs,
LAPACKE_ssyrfs_work,
LAPACKE_ssysv,
LAPACKE_ssysv_rook,
LAPACKE_ssysv_rook_work,
LAPACKE_ssysv_work,
LAPACKE_ssysvx,
LAPACKE_ssysvx_work,
@ -2298,6 +2316,10 @@
LAPACKE_zhseqr_work,
LAPACKE_zlacgv,
LAPACKE_zlacgv_work,
LAPACKE_zlacn2,
LAPACKE_zlacn2_work,
LAPACKE_zlacp2,
LAPACKE_zlacp2_work,
LAPACKE_zlacpy,
LAPACKE_zlacpy_work,
LAPACKE_zlag2c,
@ -2433,6 +2455,8 @@
LAPACKE_zsyrfs,
LAPACKE_zsyrfs_work,
LAPACKE_zsysv,
LAPACKE_zsysv_rook,
LAPACKE_zsysv_rook_work,
LAPACKE_zsysv_work,
LAPACKE_zsysvx,
LAPACKE_zsysvx_work,
@ -2562,6 +2586,7 @@
LAPACKE_csyr,
LAPACKE_zsyr_work,
LAPACKE_csyr_work,
LAPACKE_ilaver,
## @(SRCX_OBJ) from `lapack-3.4.1/lapacke/src/Makefile`
## Not exported: requires LAPACKE_EXTENDED to be set and depends on the
@ -2673,7 +2698,26 @@
);
#These function may need 2 underscores.
@lapack_embeded_underscore_objs=(xerbla_array, chla_transtype,);
@lapack_embeded_underscore_objs=(xerbla_array, chla_transtype, slasyf_rook,
ssytf2_rook, ssytrf_rook, ssytrs_rook,
ssytri_rook, ssycon_rook, ssysv_rook,
chetf2_rook, chetrf_rook, chetri_rook,
chetrs_rook, checon_rook, chesv_rook,
clahef_rook, clasyf_rook,
csytf2_rook, csytrf_rook, csytrs_rook,
csytri_rook, csycon_rook, csysv_rook,
dlasyf_rook,
dsytf2_rook, dsytrf_rook, dsytrs_rook,
dsytri_rook, dsycon_rook, dsysv_rook,
zhetf2_rook, zhetrf_rook, zhetri_rook,
zhetrs_rook, zhecon_rook, zhesv_rook,
zlahef_rook, zlasyf_rook,
zsytf2_rook, zsytrf_rook, zsytrs_rook,
zsytri_rook, zsycon_rook, zsysv_rook,
);
if ($ARGV[8] == 1) {
#ONLY_CBLAS=1

3
lapack-netlib/CMakeLists.txt
View File

@ -188,6 +188,7 @@ else()
CACHE STRING "Linker flags for shared libs" FORCE)
endif( NOT LATESTLAPACK_FOUND )
message(STATUS "BUILD TESTING : ${BUILD_TESTING}" )
if(BUILD_TESTING)
add_subdirectory(TESTING)
endif(BUILD_TESTING)
@ -200,7 +201,7 @@ option(LAPACKE "Build LAPACKE" OFF)
# if LAPACKE_WITH_TMG is selected, we need to add those routines to LAPACKE
option(LAPACKE_WITH_TMG "Build LAPACKE with tmglib routines" OFF)
if (LAPACKE_WITH_TMG)
option(LAPACKE "Build LAPACKE" ON)
set(LAPACKE ON)
if(NOT BUILD_TESTING)
add_subdirectory(TESTING/MATGEN)
endif(NOT BUILD_TESTING)

2
lapack-netlib/DOCS/Doxyfile
View File

@ -647,7 +647,7 @@ INPUT_ENCODING = UTF-8
# *.hxx *.hpp *.h++ *.idl *.odl *.cs *.php *.php3 *.inc *.m *.mm *.dox *.py
# *.f90 *.f *.for *.vhd *.vhdl
FILE_PATTERNS = *.f
FILE_PATTERNS = *
# The RECURSIVE tag can be used to turn specify whether or not subdirectories
# should be searched for input files as well. Possible values are YES and NO.

391
lapack-netlib/DOCS/psfig.tex
View File

@ -1,391 +0,0 @@
% Psfig/TeX Release 1.2
% dvi2ps-li version
%
% All software, documentation, and related files in this distribution of
% psfig/tex are Copyright 1987, 1988 Trevor J. Darrell
%
% Permission is granted for use and non-profit distribution of psfig/tex
% providing that this notice be clearly maintained, but the right to
% distribute any portion of psfig/tex for profit or as part of any commercial
% product is specifically reserved for the author.
%
% $Header$
% $Source$
%
% Thanks to Greg Hager (GDH) and Ned Batchelder for their contributions
% to this project.
%
\catcode`\@=11\relax
\newwrite\@unused
\def\typeout#1{{\let\protect\string\immediate\write\@unused{#1}}}
\typeout{psfig/tex 1.2-dvi2ps-li}
%% Here's how you define your figure path. Should be set up with null
%% default and a user useable definition.
\def\figurepath{./}
\def\psfigurepath#1{\edef\figurepath{#1}}
%
% @psdo control structure -- similar to Latex @for.
% I redefined these with different names so that psfig can
% be used with TeX as well as LaTeX, and so that it will not
% be vunerable to future changes in LaTeX's internal
% control structure,
%
\def\@nnil{\@nil}
\def\@empty{}
\def\@psdonoop#1\@@#2#3{}
\def\@psdo#1:=#2\do#3{\edef\@psdotmp{#2}\ifx\@psdotmp\@empty \else
\expandafter\@psdoloop#2,\@nil,\@nil\@@#1{#3}\fi}
\def\@psdoloop#1,#2,#3\@@#4#5{\def#4{#1}\ifx #4\@nnil \else
#5\def#4{#2}\ifx #4\@nnil \else#5\@ipsdoloop #3\@@#4{#5}\fi\fi}
\def\@ipsdoloop#1,#2\@@#3#4{\def#3{#1}\ifx #3\@nnil
\let\@nextwhile=\@psdonoop \else
#4\relax\let\@nextwhile=\@ipsdoloop\fi\@nextwhile#2\@@#3{#4}}
\def\@tpsdo#1:=#2\do#3{\xdef\@psdotmp{#2}\ifx\@psdotmp\@empty \else
\@tpsdoloop#2\@nil\@nil\@@#1{#3}\fi}
\def\@tpsdoloop#1#2\@@#3#4{\def#3{#1}\ifx #3\@nnil
\let\@nextwhile=\@psdonoop \else
#4\relax\let\@nextwhile=\@tpsdoloop\fi\@nextwhile#2\@@#3{#4}}
%
%
\def\psdraft{
\def\@psdraft{0}
%\typeout{draft level now is \@psdraft \space . }
}
\def\psfull{
\def\@psdraft{100}
%\typeout{draft level now is \@psdraft \space . }
}
\psfull
\newif\if@prologfile
\newif\if@postlogfile
\newif\if@noisy
\def\pssilent{
\@noisyfalse
}
\def\psnoisy{
\@noisytrue
}
\psnoisy
%%% These are for the option list.
%%% A specification of the form a = b maps to calling \@p@@sa{b}
\newif\if@bbllx
\newif\if@bblly
\newif\if@bburx
\newif\if@bbury
\newif\if@height
\newif\if@width
\newif\if@rheight
\newif\if@rwidth
\newif\if@clip
\newif\if@verbose
\def\@p@@sclip#1{\@cliptrue}
%%% GDH 7/26/87 -- changed so that it first looks in the local directory,
%%% then in a specified global directory for the ps file.
\def\@p@@sfile#1{\def\@p@sfile{null}%
\openin1=#1
\ifeof1\closein1%
\openin1=\figurepath#1
\ifeof1\typeout{Error, File #1 not found}
\else\closein1
\edef\@p@sfile{\figurepath#1}%
\fi%
\else\closein1%
\def\@p@sfile{#1}%
\fi}
\def\@p@@sfigure#1{\def\@p@sfile{null}%
\openin1=#1
\ifeof1\closein1%
\openin1=\figurepath#1
\ifeof1\typeout{Error, File #1 not found}
\else\closein1
\def\@p@sfile{\figurepath#1}%
\fi%
\else\closein1%
\def\@p@sfile{#1}%
\fi}
\def\@p@@sbbllx#1{
%\typeout{bbllx is #1}
\@bbllxtrue
\dimen100=#1
\edef\@p@sbbllx{\number\dimen100}
}
\def\@p@@sbblly#1{
%\typeout{bblly is #1}
\@bbllytrue
\dimen100=#1
\edef\@p@sbblly{\number\dimen100}
}
\def\@p@@sbburx#1{
%\typeout{bburx is #1}
\@bburxtrue
\dimen100=#1
\edef\@p@sbburx{\number\dimen100}
}
\def\@p@@sbbury#1{
%\typeout{bbury is #1}
\@bburytrue
\dimen100=#1
\edef\@p@sbbury{\number\dimen100}
}
\def\@p@@sheight#1{
\@heighttrue
\dimen100=#1
\edef\@p@sheight{\number\dimen100}
%\typeout{Height is \@p@sheight}
}
\def\@p@@swidth#1{
%\typeout{Width is #1}
\@widthtrue
\dimen100=#1
\edef\@p@swidth{\number\dimen100}
}
\def\@p@@srheight#1{
%\typeout{Reserved height is #1}
\@rheighttrue
\dimen100=#1
\edef\@p@srheight{\number\dimen100}
}
\def\@p@@srwidth#1{
%\typeout{Reserved width is #1}
\@rwidthtrue
\dimen100=#1
\edef\@p@srwidth{\number\dimen100}
}
\def\@p@@ssilent#1{
\@verbosefalse
}
\def\@p@@sprolog#1{\@prologfiletrue\def\@prologfileval{#1}}
\def\@p@@spostlog#1{\@postlogfiletrue\def\@postlogfileval{#1}}
\def\@cs@name#1{\csname #1\endcsname}
\def\@setparms#1=#2,{\@cs@name{@p@@s#1}{#2}}
%
% initialize the defaults (size the size of the figure)
%
\def\ps@init@parms{
\@bbllxfalse \@bbllyfalse
\@bburxfalse \@bburyfalse
\@heightfalse \@widthfalse
\@rheightfalse \@rwidthfalse
\def\@p@sbbllx{}\def\@p@sbblly{}
\def\@p@sbburx{}\def\@p@sbbury{}
\def\@p@sheight{}\def\@p@swidth{}
\def\@p@srheight{}\def\@p@srwidth{}
\def\@p@sfile{}
\def\@p@scost{10}
\def\@sc{}
\@prologfilefalse
\@postlogfilefalse
\@clipfalse
\if@noisy
\@verbosetrue
\else
\@verbosefalse
\fi
}
%
% Go through the options setting things up.
%
\def\parse@ps@parms#1{
\@psdo\@psfiga:=#1\do
{\expandafter\@setparms\@psfiga,}}
%
% Compute bb height and width
%
\newif\ifno@bb
\newif\ifnot@eof
\newread\ps@stream
\def\bb@missing{
\if@verbose{
\typeout{psfig: searching \@p@sfile \space for bounding box}
}\fi
\openin\ps@stream=\@p@sfile
\no@bbtrue
\not@eoftrue
\catcode`\%=12
\loop
\read\ps@stream to \line@in
\global\toks200=\expandafter{\line@in}
\ifeof\ps@stream \not@eoffalse \fi
%\typeout{ looking at :: \the\toks200 }
\@bbtest{\toks200}
\if@bbmatch\not@eoffalse\expandafter\bb@cull\the\toks200\fi
\ifnot@eof \repeat
\catcode`\%=14
}
\catcode`\%=12
\newif\if@bbmatch
\def\@bbtest#1{\expandafter\@a@\the#1%%BoundingBox:\@bbtest\@a@}
\long\def\@a@#1%%BoundingBox:#2#3\@a@{\ifx\@bbtest#2\@bbmatchfalse\else\@bbmatchtrue\fi}
\long\def\bb@cull#1 #2 #3 #4 #5 {
\dimen100=#2 bp\edef\@p@sbbllx{\number\dimen100}
\dimen100=#3 bp\edef\@p@sbblly{\number\dimen100}
\dimen100=#4 bp\edef\@p@sbburx{\number\dimen100}
\dimen100=#5 bp\edef\@p@sbbury{\number\dimen100}
\no@bbfalse
}
\catcode`\%=14
%
\def\compute@bb{
\no@bbfalse
\if@bbllx \else \no@bbtrue \fi
\if@bblly \else \no@bbtrue \fi
\if@bburx \else \no@bbtrue \fi
\if@bbury \else \no@bbtrue \fi
\ifno@bb \bb@missing \fi
\ifno@bb \typeout{FATAL ERROR: no bb supplied or found}
\no-bb-error
\fi
%
\count203=\@p@sbburx
\count204=\@p@sbbury
\advance\count203 by -\@p@sbbllx
\advance\count204 by -\@p@sbblly
\edef\@bbw{\number\count203}
\edef\@bbh{\number\count204}
%\typeout{ bbh = \@bbh, bbw = \@bbw }
}
%
% \in@hundreds performs #1 * (#2 / #3) correct to the hundreds,
% then leaves the result in @result
%
\def\in@hundreds#1#2#3{\count240=#2 \count241=#3
\count100=\count240 % 100 is first digit #2/#3
\divide\count100 by \count241
\count101=\count100
\multiply\count101 by \count241
\advance\count240 by -\count101
\multiply\count240 by 10
\count101=\count240 %101 is second digit of #2/#3
\divide\count101 by \count241
\count102=\count101
\multiply\count102 by \count241
\advance\count240 by -\count102
\multiply\count240 by 10
\count102=\count240 % 102 is the third digit
\divide\count102 by \count241
\count200=#1\count205=0
\count201=\count200
\multiply\count201 by \count100
\advance\count205 by \count201
\count201=\count200
\divide\count201 by 10
\multiply\count201 by \count101
\advance\count205 by \count201
%
\count201=\count200
\divide\count201 by 100
\multiply\count201 by \count102
\advance\count205 by \count201
%
\edef\@result{\number\count205}
}
\def\compute@wfromh{
% computing : width = height * (bbw / bbh)
\in@hundreds{\@p@sheight}{\@bbw}{\@bbh}
%\typeout{ \@p@sheight * \@bbw / \@bbh, = \@result }
\edef\@p@swidth{\@result}
%\typeout{w from h: width is \@p@swidth}
}
\def\compute@hfromw{
% computing : height = width * (bbh / bbw)
\in@hundreds{\@p@swidth}{\@bbh}{\@bbw}
%\typeout{ \@p@swidth * \@bbh / \@bbw = \@result }
\edef\@p@sheight{\@result}
%\typeout{h from w : height is \@p@sheight}
}
\def\compute@handw{
\if@height
\if@width
\else
\compute@wfromh
\fi
\else
\if@width
\compute@hfromw
\else
\edef\@p@sheight{\@bbh}
\edef\@p@swidth{\@bbw}
\fi
\fi
}
\def\compute@resv{
\if@rheight \else \edef\@p@srheight{\@p@sheight} \fi
\if@rwidth \else \edef\@p@srwidth{\@p@swidth} \fi
}
%
% Compute any missing values
\def\compute@sizes{
\compute@bb
\compute@handw
\compute@resv
}
%
% \psfig
% usage : \psfig{file=, height=, width=, bbllx=, bblly=, bburx=, bbury=,
% rheight=, rwidth=, clip=}
%
% "clip=" is a switch and takes no value, but the `=' must be present.
\def\psfig#1{\vbox {
% do a zero width hard space so that a single
% \psfig in a centering enviornment will behave nicely
%{\setbox0=\hbox{\ }\ \hskip-\wd0}
%
\ps@init@parms
\parse@ps@parms{#1}
\compute@sizes
%
\ifnum\@p@scost<\@psdraft{
\if@verbose{
\typeout{psfig: including \@p@sfile \space }
}\fi
%
\special{ pstext="\@p@swidth \space
\@p@sheight \space
\@p@sbbllx \space \@p@sbblly \space
\@p@sbburx \space
\@p@sbbury \space startTexFig" \space}
\if@clip{
\if@verbose{
\typeout{(clip)}
}\fi
\special{ pstext="doclip \space"}
}\fi
\if@prologfile
\special{psfile=\@prologfileval \space } \fi
\special{psfile=\@p@sfile \space }
\if@postlogfile
\special{psfile=\@postlogfileval \space } \fi
\special{pstext=endTexFig \space }
% Create the vbox to reserve the space for the figure
\vbox to \@p@srheight true sp{
\hbox to \@p@srwidth true sp{
\hss
}
\vss
}
}\else{
% draft figure, just reserve the space and print the
% path name.
\vbox to \@p@srheight true sp{
\vss
\hbox to \@p@srwidth true sp{
\hss
\if@verbose{
\@p@sfile
}\fi
\hss
}
\vss
}
}\fi
}}
\def\psglobal{\typeout{psfig: PSGLOBAL is OBSOLETE; use psprint -m instead}}
\catcode`\@=12\relax

4
lapack-netlib/INSTALL/dlamch.f
View File

@ -72,6 +72,10 @@
CHARACTER CMACH
* ..
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B
* ..
*
* =====================================================================
*
* .. Parameters ..

8
lapack-netlib/INSTALL/ilaver.f
View File

@ -41,14 +41,14 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
@ -58,8 +58,8 @@
INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
* =====================================================================
VERS_MAJOR = 3
VERS_MINOR = 4
VERS_PATCH = 2
VERS_MINOR = 5
VERS_PATCH = 0
* =====================================================================
*
RETURN

4
lapack-netlib/INSTALL/make.inc.ALPHA
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /bin/sh

4
lapack-netlib/INSTALL/make.inc.HPPA
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /bin/sh

4
lapack-netlib/INSTALL/make.inc.IRIX64
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /sbin/sh

4
lapack-netlib/INSTALL/make.inc.O2K
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /sbin/sh

4
lapack-netlib/INSTALL/make.inc.SGI5
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /sbin/sh

4
lapack-netlib/INSTALL/make.inc.SUN4
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /bin/sh

4
lapack-netlib/INSTALL/make.inc.SUN4SOL2
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /bin/sh

4
lapack-netlib/INSTALL/make.inc.XLF
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /bin/sh

8
lapack-netlib/INSTALL/make.inc.gfortran
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /bin/sh
@ -13,9 +13,9 @@ SHELL = /bin/sh
# desired load options for your machine.
#
FORTRAN = gfortran
OPTS = -O2
OPTS = -O2 -frecursive
DRVOPTS = $(OPTS)
NOOPT = -O0
NOOPT = -O0 -frecursive
LOADER = gfortran
LOADOPTS =
#

8
lapack-netlib/INSTALL/make.inc.gfortran_debug
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /bin/sh
@ -12,10 +12,10 @@ SHELL = /bin/sh
# selected. Define LOADER and LOADOPTS to refer to the loader
# and desired load options for your machine.
#
FORTRAN = gfortran -fimplicit-none -g
FORTRAN = gfortran -fimplicit-none -g -frecursive
OPTS =
DRVOPTS = $(OPTS)
NOOPT = -g -O0
NOOPT = -g -O0 -frecursive
LOADER = gfortran -g
LOADOPTS =
#

4
lapack-netlib/INSTALL/make.inc.ifort
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /bin/sh

4
lapack-netlib/INSTALL/make.inc.pgf95
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /bin/sh

4
lapack-netlib/INSTALL/make.inc.pghpf
View File

@ -1,7 +1,7 @@
####################################################################
# LAPACK make include file. #
# LAPACK, Version 3.4.1 #
# April 2012 #
# LAPACK, Version 3.5.0 #
# November 2013 #
####################################################################
#
SHELL = /bin/sh

5
lapack-netlib/README
View File

@ -20,6 +20,7 @@ VERSION 3.3.1 : April 2011
VERSION 3.4.0 : November 2011
VERSION 3.4.1 : April 2012
VERSION 3.4.2 : September 2012
VERSION 3.5.0 : November 2013
LAPACK is a library of Fortran 90 with subroutines for solving
the most commonly occurring problems in numerical linear algebra.
@ -40,8 +41,8 @@ very much on the efficiency of the BLAS.
=================
LAPACK INSTALLATION:
- LAPACK can be installed with make. Configuration haev to be set in the
make.inc file. A make.inc.example for a Linux mahcine running GNU compilers
- LAPACK can be installed with make. Configuration have to be set in the
make.inc file. A make.inc.example for a Linux machine running GNU compilers
is given in the main directory. Some specific make.inc are also available in
the INSTALL directory
- LAPACK includes also the CMAKE build. You will need to have CMAKE installed

40
lapack-netlib/SRC/CMakeLists.txt
View File

@ -113,7 +113,7 @@ set(SLASRC
slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f
slarf.f slarfb.f slarfg.f slarfgp.f slarft.f slarfx.f slargv.f
slarrv.f slartv.f
slarz.f slarzb.f slarzt.f slaswp.f slasy2.f slasyf.f
slarz.f slarzb.f slarzt.f slaswp.f slasy2.f slasyf.f slasyf_rook.f
slatbs.f slatdf.f slatps.f slatrd.f slatrs.f slatrz.f slatzm.f
slauu2.f slauum.f sopgtr.f sopmtr.f sorg2l.f sorg2r.f
sorgbr.f sorghr.f sorgl2.f sorglq.f sorgql.f sorgqr.f sorgr2.f
@ -134,6 +134,8 @@ set(SLASRC
ssygst.f ssygv.f ssygvd.f ssygvx.f ssyrfs.f ssysv.f ssysvx.f
ssytd2.f ssytf2.f ssytrd.f ssytrf.f ssytri.f ssytri2.f ssytri2x.f
ssyswapr.f ssytrs.f ssytrs2.f ssyconv.f
ssytf2_rook.f ssytrf_rook.f ssytrs_rook.f
ssytri_rook.f ssycon_rook.f ssysv_rook.f
stbcon.f
stbrfs.f stbtrs.f stgevc.f stgex2.f stgexc.f stgsen.f
stgsja.f stgsna.f stgsy2.f stgsyl.f stpcon.f stprfs.f stptri.f
@ -144,7 +146,8 @@ set(SLASRC
stfttr.f stpttf.f stpttr.f strttf.f strttp.f
sgejsv.f sgesvj.f sgsvj0.f sgsvj1.f
sgeequb.f ssyequb.f spoequb.f sgbequb.f
sbbcsd.f slapmr.f sorbdb.f sorcsd.f
sbbcsd.f slapmr.f sorbdb.f sorbdb1.f sorbdb2.f sorbdb3.f sorbdb4.f
sorbdb5.f sorbdb6.f sorcsd.f sorcsd2by1.f
sgeqrt.f sgeqrt2.f sgeqrt3.f sgemqrt.f
stpqrt.f stpqrt2.f stpmqrt.f stprfb.f
)
@ -177,14 +180,16 @@ set(CLASRC
chegv.f chegvd.f chegvx.f cherfs.f chesv.f chesvx.f chetd2.f
chetf2.f chetrd.f
chetrf.f chetri.f chetri2.f chetri2x.f cheswapr.f
chetrs.f chetrs2.f chgeqz.f chpcon.f chpev.f chpevd.f
chetrs.f chetrs2.f
chetf2_rook.f chetrf_rook.f chetri_rook.f chetrs_rook.f checon_rook.f chesv_rook.f
chgeqz.f chpcon.f chpev.f chpevd.f
chpevx.f chpgst.f chpgv.f chpgvd.f chpgvx.f chprfs.f chpsv.f
chpsvx.f
chptrd.f chptrf.f chptri.f chptrs.f chsein.f chseqr.f clabrd.f
clacgv.f clacon.f clacn2.f clacp2.f clacpy.f clacrm.f clacrt.f cladiv.f
claed0.f claed7.f claed8.f
claein.f claesy.f claev2.f clags2.f clagtm.f
clahef.f clahqr.f
clahef.f clahef_rook.f clahqr.f
clahrd.f clahr2.f claic1.f clals0.f clalsa.f clalsd.f clangb.f clange.f clangt.f
clanhb.f clanhe.f
clanhp.f clanhs.f clanht.f clansb.f clansp.f clansy.f clantb.f
@ -195,7 +200,7 @@ set(CLASRC
clarf.f clarfb.f clarfg.f clarfgp.f clarft.f
clarfx.f clargv.f clarnv.f clarrv.f clartg.f clartv.f
clarz.f clarzb.f clarzt.f clascl.f claset.f clasr.f classq.f
claswp.f clasyf.f clatbs.f clatdf.f clatps.f clatrd.f clatrs.f clatrz.f
claswp.f clasyf.f clasyf_rook.f clatbs.f clatdf.f clatps.f clatrd.f clatrs.f clatrz.f
clatzm.f clauu2.f clauum.f cpbcon.f cpbequ.f cpbrfs.f cpbstf.f cpbsv.f
cpbsvx.f cpbtf2.f cpbtrf.f cpbtrs.f cpocon.f cpoequ.f cporfs.f
cposv.f cposvx.f cpotf2.f cpotrf.f cpotri.f cpotrs.f cpstrf.f cpstf2.f
@ -207,6 +212,8 @@ set(CLASRC
csyr.f csyrfs.f csysv.f csysvx.f csytf2.f csytrf.f csytri.f
csytri2.f csytri2x.f csyswapr.f
csytrs.f csytrs2.f csyconv.f
csytf2_rook.f csytrf_rook.f csytrs_rook.f
csytri_rook.f csycon_rook.f csysv_rook.f
ctbcon.f ctbrfs.f ctbtrs.f ctgevc.f ctgex2.f
ctgexc.f ctgsen.f ctgsja.f ctgsna.f ctgsy2.f ctgsyl.f ctpcon.f
ctprfs.f ctptri.f
@ -219,7 +226,8 @@ set(CLASRC
chfrk.f ctfttp.f clanhf.f cpftrf.f cpftri.f cpftrs.f ctfsm.f ctftri.f
ctfttr.f ctpttf.f ctpttr.f ctrttf.f ctrttp.f
cgeequb.f cgbequb.f csyequb.f cpoequb.f cheequb.f
cbbcsd.f clapmr.f cunbdb.f cuncsd.f
cbbcsd.f clapmr.f cunbdb.f cunbdb1.f cunbdb2.f cunbdb3.f cunbdb4.f
cunbdb5.f cunbdb6.f cuncsd.f cuncsd2by1.f
cgeqrt.f cgeqrt2.f cgeqrt3.f cgemqrt.f
ctpqrt.f ctpqrt2.f ctpmqrt.f ctprfb.f)
@ -261,7 +269,7 @@ set(DLASRC
dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f
dlarf.f dlarfb.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlargv.f
dlarrv.f dlartv.f
dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f
dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f dlasyf_rook.f
dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.f dlatrz.f dlatzm.f dlauu2.f
dlauum.f dopgtr.f dopmtr.f dorg2l.f dorg2r.f
dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgr2.f
@ -283,6 +291,8 @@ set(DLASRC
dsysv.f dsysvx.f
dsytd2.f dsytf2.f dsytrd.f dsytrf.f dsytri.f dsytrs.f dsytrs2.f
dsytri2.f dsytri2x.f dsyswapr.f dsyconv.f
dsytf2_rook.f dsytrf_rook.f dsytrs_rook.f
dsytri_rook.f dsycon_rook.f dsysv_rook.f
dtbcon.f
dtbrfs.f dtbtrs.f dtgevc.f dtgex2.f dtgexc.f dtgsen.f
dtgsja.f dtgsna.f dtgsy2.f dtgsyl.f dtpcon.f dtprfs.f dtptri.f
@ -294,7 +304,8 @@ set(DLASRC
dtfttr.f dtpttf.f dtpttr.f dtrttf.f dtrttp.f
dgejsv.f dgesvj.f dgsvj0.f dgsvj1.f
dgeequb.f dsyequb.f dpoequb.f dgbequb.f
dbbcsd.f dlapmr.f dorbdb.f dorcsd.f
dbbcsd.f dlapmr.f dorbdb.f dorbdb1.f dorbdb2.f dorbdb3.f dorbdb4.f
dorbdb5.f dorbdb6.f dorcsd.f dorcsd2by1.f
dgeqrt.f dgeqrt2.f dgeqrt3.f dgemqrt.f
dtpqrt.f dtpqrt2.f dtpmqrt.f dtprfb.f )
@ -324,14 +335,16 @@ set(ZLASRC
zhegv.f zhegvd.f zhegvx.f zherfs.f zhesv.f zhesvx.f zhetd2.f
zhetf2.f zhetrd.f
zhetrf.f zhetri.f zhetri2.f zhetri2x.f zheswapr.f
zhetrs.f zhetrs2.f zhgeqz.f zhpcon.f zhpev.f zhpevd.f
zhetrs.f zhetrs2.f
zhetf2_rook.f zhetrf_rook.f zhetri_rook.f zhetrs_rook.f zhecon_rook.f zhesv_rook.f
zhgeqz.f zhpcon.f zhpev.f zhpevd.f
zhpevx.f zhpgst.f zhpgv.f zhpgvd.f zhpgvx.f zhprfs.f zhpsv.f
zhpsvx.f
zhptrd.f zhptrf.f zhptri.f zhptrs.f zhsein.f zhseqr.f zlabrd.f
zlacgv.f zlacon.f zlacn2.f zlacp2.f zlacpy.f zlacrm.f zlacrt.f zladiv.f
zlaed0.f zlaed7.f zlaed8.f
zlaein.f zlaesy.f zlaev2.f zlags2.f zlagtm.f
zlahef.f zlahqr.f
zlahef.f zlahef_rook.f zlahqr.f
zlahrd.f zlahr2.f zlaic1.f zlals0.f zlalsa.f zlalsd.f zlangb.f zlange.f
zlangt.f zlanhb.f
zlanhe.f
@ -344,7 +357,7 @@ set(ZLASRC
zlarfg.f zlarfgp.f zlarft.f
zlarfx.f zlargv.f zlarnv.f zlarrv.f zlartg.f zlartv.f
zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f
zlassq.f zlaswp.f zlasyf.f
zlassq.f zlaswp.f zlasyf.f zlasyf_rook.f
zlatbs.f zlatdf.f zlatps.f zlatrd.f zlatrs.f zlatrz.f zlatzm.f zlauu2.f
zlauum.f zpbcon.f zpbequ.f zpbrfs.f zpbstf.f zpbsv.f
zpbsvx.f zpbtf2.f zpbtrf.f zpbtrs.f zpocon.f zpoequ.f zporfs.f
@ -357,6 +370,8 @@ set(ZLASRC
zsyr.f zsyrfs.f zsysv.f zsysvx.f zsytf2.f zsytrf.f zsytri.f
zsytri2.f zsytri2x.f zsyswapr.f
zsytrs.f zsytrs2.f zsyconv.f
zsytf2_rook.f zsytrf_rook.f zsytrs_rook.f
zsytri_rook.f zsycon_rook.f zsysv_rook.f
ztbcon.f ztbrfs.f ztbtrs.f ztgevc.f ztgex2.f
ztgexc.f ztgsen.f ztgsja.f ztgsna.f ztgsy2.f ztgsyl.f ztpcon.f
ztprfs.f ztptri.f
@ -371,7 +386,8 @@ set(ZLASRC
zhfrk.f ztfttp.f zlanhf.f zpftrf.f zpftri.f zpftrs.f ztfsm.f ztftri.f
ztfttr.f ztpttf.f ztpttr.f ztrttf.f ztrttp.f
zgeequb.f zgbequb.f zsyequb.f zpoequb.f zheequb.f
zbbcsd.f zlapmr.f zunbdb.f zuncsd.f
zbbcsd.f zlapmr.f zunbdb.f zunbdb1.f zunbdb2.f zunbdb3.f zunbdb4.f
zunbdb5.f zunbdb6.f zuncsd.f zuncsd2by1.f
zgeqrt.f zgeqrt2.f zgeqrt3.f zgemqrt.f
ztpqrt.f ztpqrt2.f ztpmqrt.f ztprfb.f)

40
lapack-netlib/SRC/Makefile
View File

@ -118,7 +118,7 @@ SLASRC = \
slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \
slarf.o slarfb.o slarfg.o slarfgp.o slarft.o slarfx.o slargv.o \
slarrv.o slartv.o \
slarz.o slarzb.o slarzt.o slasy2.o slasyf.o \
slarz.o slarzb.o slarzt.o slasy2.o slasyf.o slasyf_rook.o \
slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o slatzm.o \
sopgtr.o sopmtr.o sorg2l.o sorg2r.o \
sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \
@ -140,6 +140,8 @@ SLASRC = \
ssygst.o ssygv.o ssygvd.o ssygvx.o ssyrfs.o ssysv.o ssysvx.o \
ssytd2.o ssytf2.o ssytrd.o ssytrf.o ssytri.o ssytri2.o ssytri2x.o \
ssyswapr.o ssytrs.o ssytrs2.o ssyconv.o \
ssytf2_rook.o ssytrf_rook.o ssytrs_rook.o \
ssytri_rook.o ssycon_rook.o ssysv_rook.o \
stbcon.o \
stbrfs.o stbtrs.o stgevc.o stgex2.o stgexc.o stgsen.o \
stgsja.o stgsna.o stgsy2.o stgsyl.o stpcon.o stprfs.o stptri.o \
@ -150,7 +152,8 @@ SLASRC = \
stfttr.o stpttf.o stpttr.o strttf.o strttp.o \
sgejsv.o sgesvj.o sgsvj0.o sgsvj1.o \
sgeequb.o ssyequb.o spoequb.o sgbequb.o \
sbbcsd.o slapmr.o sorbdb.o sorcsd.o \
sbbcsd.o slapmr.o sorbdb.o sorbdb1.o sorbdb2.o sorbdb3.o sorbdb4.o \
sorbdb5.o sorbdb6.o sorcsd.o sorcsd2by1.o \
sgeqrt.o sgeqrt2.o sgeqrt3.o sgemqrt.o \
stpqrt.o stpqrt2.o stpmqrt.o stprfb.o
@ -184,14 +187,16 @@ CLASRC = \
chegv.o chegvd.o chegvx.o cherfs.o chesv.o chesvx.o chetd2.o \
chetf2.o chetrd.o \
chetrf.o chetri.o chetri2.o chetri2x.o cheswapr.o \
chetrs.o chetrs2.o chgeqz.o chpcon.o chpev.o chpevd.o \
chetrs.o chetrs2.o \
chetf2_rook.o chetrf_rook.o chetri_rook.o chetrs_rook.o checon_rook.o chesv_rook.o \
chgeqz.o chpcon.o chpev.o chpevd.o \
chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.o \
chpsvx.o \
chptrd.o chptrf.o chptri.o chptrs.o chsein.o chseqr.o clabrd.o \
clacgv.o clacon.o clacn2.o clacp2.o clacpy.o clacrm.o clacrt.o cladiv.o \
claed0.o claed7.o claed8.o \
claein.o claesy.o claev2.o clags2.o clagtm.o \
clahef.o clahqr.o \
clahef.o clahef_rook.o clahqr.o \
clahrd.o clahr2.o claic1.o clals0.o clalsa.o clalsd.o clangb.o clange.o clangt.o \
clanhb.o clanhe.o \
clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \
@ -202,7 +207,7 @@ CLASRC = \
clarf.o clarfb.o clarfg.o clarft.o clarfgp.o \
clarfx.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \
clarz.o clarzb.o clarzt.o clascl.o claset.o clasr.o classq.o \
clasyf.o clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \
clasyf.o clasyf_rook.o clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \
clatzm.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \
cpbsvx.o cpbtf2.o cpbtrf.o cpbtrs.o cpocon.o cpoequ.o cporfs.o \
cposv.o cposvx.o cpotri.o cpstrf.o cpstf2.o \
@ -214,6 +219,8 @@ CLASRC = \
csycon.o csymv.o \
csyr.o csyrfs.o csysv.o csysvx.o csytf2.o csytrf.o csytri.o csytri2.o csytri2x.o \
csyswapr.o csytrs.o csytrs2.o csyconv.o \
csytf2_rook.o csytrf_rook.o csytrs_rook.o \
csytri_rook.o csycon_rook.o csysv_rook.o \
ctbcon.o ctbrfs.o ctbtrs.o ctgevc.o ctgex2.o \
ctgexc.o ctgsen.o ctgsja.o ctgsna.o ctgsy2.o ctgsyl.o ctpcon.o \
ctprfs.o ctptri.o \
@ -226,7 +233,8 @@ CLASRC = \
chfrk.o ctfttp.o clanhf.o cpftrf.o cpftri.o cpftrs.o ctfsm.o ctftri.o \
ctfttr.o ctpttf.o ctpttr.o ctrttf.o ctrttp.o \
cgeequb.o cgbequb.o csyequb.o cpoequb.o cheequb.o \
cbbcsd.o clapmr.o cunbdb.o cuncsd.o \
cbbcsd.o clapmr.o cunbdb.o cunbdb1.o cunbdb2.o cunbdb3.o cunbdb4.o \
cunbdb5.o cunbdb6.o cuncsd.o cuncsd2by1.o \
cgeqrt.o cgeqrt2.o cgeqrt3.o cgemqrt.o \
ctpqrt.o ctpqrt2.o ctpmqrt.o ctprfb.o
@ -270,7 +278,7 @@ DLASRC = \
dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \
dlarf.o dlarfb.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o \
dlargv.o dlarrv.o dlartv.o \
dlarz.o dlarzb.o dlarzt.o dlasy2.o dlasyf.o \
dlarz.o dlarzb.o dlarzt.o dlasy2.o dlasyf.o dlasyf_rook.o \
dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlatzm.o \
dopgtr.o dopmtr.o dorg2l.o dorg2r.o \
dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \
@ -293,6 +301,8 @@ DLASRC = \
dsysv.o dsysvx.o \
dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytri2.o dsytri2x.o \
dsyswapr.o dsytrs.o dsytrs2.o dsyconv.o \
dsytf2_rook.o dsytrf_rook.o dsytrs_rook.o \
dsytri_rook.o dsycon_rook.o dsysv_rook.o \
dtbcon.o dtbrfs.o dtbtrs.o dtgevc.o dtgex2.o dtgexc.o dtgsen.o \
dtgsja.o dtgsna.o dtgsy2.o dtgsyl.o dtpcon.o dtprfs.o dtptri.o \
dtptrs.o \
@ -303,7 +313,8 @@ DLASRC = \
dtfttr.o dtpttf.o dtpttr.o dtrttf.o dtrttp.o \
dgejsv.o dgesvj.o dgsvj0.o dgsvj1.o \
dgeequb.o dsyequb.o dpoequb.o dgbequb.o \
dbbcsd.o dlapmr.o dorbdb.o dorcsd.o \
dbbcsd.o dlapmr.o dorbdb.o dorbdb1.o dorbdb2.o dorbdb3.o dorbdb4.o \
dorbdb5.o dorbdb6.o dorcsd.o dorcsd2by1.o \
dgeqrt.o dgeqrt2.o dgeqrt3.o dgemqrt.o \
dtpqrt.o dtpqrt2.o dtpmqrt.o dtprfb.o
@ -335,14 +346,16 @@ ZLASRC = \
zhegv.o zhegvd.o zhegvx.o zherfs.o zhesv.o zhesvx.o zhetd2.o \
zhetf2.o zhetrd.o \
zhetrf.o zhetri.o zhetri2.o zhetri2x.o zheswapr.o \
zhetrs.o zhetrs2.o zhgeqz.o zhpcon.o zhpev.o zhpevd.o \
zhetrs.o zhetrs2.o \
zhetf2_rook.o zhetrf_rook.o zhetri_rook.o zhetrs_rook.o zhecon_rook.o zhesv_rook.o \
zhgeqz.o zhpcon.o zhpev.o zhpevd.o \
zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o \
zhpsvx.o \
zhptrd.o zhptrf.o zhptri.o zhptrs.o zhsein.o zhseqr.o zlabrd.o \
zlacgv.o zlacon.o zlacn2.o zlacp2.o zlacpy.o zlacrm.o zlacrt.o zladiv.o \
zlaed0.o zlaed7.o zlaed8.o \
zlaein.o zlaesy.o zlaev2.o zlags2.o zlagtm.o \
zlahef.o zlahqr.o \
zlahef.o zlahef_rook.o zlahqr.o \
zlahrd.o zlahr2.o zlaic1.o zlals0.o zlalsa.o zlalsd.o zlangb.o zlange.o \
zlangt.o zlanhb.o \
zlanhe.o \
@ -355,7 +368,7 @@ ZLASRC = \
zlarfg.o zlarft.o zlarfgp.o \
zlarfx.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \
zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \
zlassq.o zlasyf.o \
zlassq.o zlasyf.o zlasyf_rook.o \
zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o zlatzm.o zlauu2.o \
zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \
zpbsvx.o zpbtf2.o zpbtrf.o zpbtrs.o zpocon.o zpoequ.o zporfs.o \
@ -368,6 +381,8 @@ ZLASRC = \
zsycon.o zsymv.o \
zsyr.o zsyrfs.o zsysv.o zsysvx.o zsytf2.o zsytrf.o zsytri.o zsytri2.o zsytri2x.o \
zsyswapr.o zsytrs.o zsytrs2.o zsyconv.o \
zsytf2_rook.o zsytrf_rook.o zsytrs_rook.o \
zsytri_rook.o zsycon_rook.o zsysv_rook.o \
ztbcon.o ztbrfs.o ztbtrs.o ztgevc.o ztgex2.o \
ztgexc.o ztgsen.o ztgsja.o ztgsna.o ztgsy2.o ztgsyl.o ztpcon.o \
ztprfs.o ztptri.o \
@ -382,7 +397,8 @@ ZLASRC = \
zhfrk.o ztfttp.o zlanhf.o zpftrf.o zpftri.o zpftrs.o ztfsm.o ztftri.o \
ztfttr.o ztpttf.o ztpttr.o ztrttf.o ztrttp.o \
zgeequb.o zgbequb.o zsyequb.o zpoequb.o zheequb.o \
zbbcsd.o zlapmr.o zunbdb.o zuncsd.o \
zbbcsd.o zlapmr.o zunbdb.o zunbdb1.o zunbdb2.o zunbdb3.o zunbdb4.o \
zunbdb5.o zunbdb6.o zuncsd.o zuncsd2by1.o \
zgeqrt.o zgeqrt2.o zgeqrt3.o zgemqrt.o \
ztpqrt.o ztpqrt2.o ztpmqrt.o ztprfb.o

11
lapack-netlib/SRC/cbbcsd.f
View File

@ -322,7 +322,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@ -332,10 +332,10 @@
$ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E,
$ B22D, B22E, RWORK, LRWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS
@ -477,7 +477,10 @@
* Initial deflation
*
IMAX = Q
DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) )
DO WHILE( IMAX .GT. 1 )
IF( PHI(IMAX-1) .NE. ZERO ) THEN
EXIT
END IF
IMAX = IMAX - 1
END DO
IMIN = IMAX - 1

20
lapack-netlib/SRC/cgebal.f
View File

@ -122,7 +122,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup complexGEcomputational
*
@ -161,10 +161,10 @@
* =====================================================================
SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOB
@ -195,8 +195,8 @@
* .. External Functions ..
LOGICAL SISNAN, LSAME
INTEGER ICAMAX
REAL SLAMCH
EXTERNAL SISNAN, LSAME, ICAMAX, SLAMCH
REAL SLAMCH, SCNRM2
EXTERNAL SISNAN, LSAME, ICAMAX, SLAMCH, SCNRM2
* ..
* .. External Subroutines ..
EXTERNAL CSSCAL, CSWAP, XERBLA
@ -325,15 +325,9 @@
NOCONV = .FALSE.
*
DO 200 I = K, L
C = ZERO
R = ZERO
*
DO 150 J = K, L
IF( J.EQ.I )
$ GO TO 150
C = C + CABS1( A( J, I ) )
R = R + CABS1( A( I, J ) )
150 CONTINUE
C = SCNRM2( L-K+1, A( K, I ), 1 )
R = SCNRM2( L-K+1, A( I , K ), LDA )
ICA = ICAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = ICAMAX( N-K+1, A( I, K ), LDA )

8
lapack-netlib/SRC/cgemqrt.f
View File

@ -160,7 +160,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup complexGEcomputational
*
@ -168,10 +168,10 @@
SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@ -225,7 +225,7 @@
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN
INFO = -5
ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN
INFO = -6
ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
INFO = -8

8
lapack-netlib/SRC/cgeqrt.f
View File

@ -108,7 +108,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup complexGEcomputational
*
@ -141,10 +141,10 @@
* =====================================================================
SUBROUTINE CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDT, M, N, NB
@ -173,7 +173,7 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN
ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5

12
lapack-netlib/SRC/cgetc2.f
View File

@ -98,7 +98,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup complexGEauxiliary
*
@ -111,10 +111,10 @@
* =====================================================================
SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
@ -203,6 +203,12 @@
INFO = N
A( N, N ) = CMPLX( SMIN, ZERO )
END IF
*
* Set last pivots to N
*
IPIV( N ) = N
JPIV( N ) = N
*
RETURN
*
* End of CGETC2

253
lapack-netlib/SRC/checon_rook.f Normal file
View File

@ -0,0 +1,253 @@
*> \brief \b CHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges)
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHECON_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/checon_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/checon_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/checon_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* REAL ANORM, RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHECON_ROOK estimates the reciprocal of the condition number of a complex
*> Hermitian matrix A using the factorization A = U*D*U**H or
*> A = L*D*L**H computed by CHETRF_ROOK.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**H;
*> = 'L': Lower triangular, form is A = L*D*L**H.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by CHETRF_ROOK.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by CHETRF_ROOK.
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*> ANORM is REAL
*> The 1-norm of the original matrix A.
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*> RCOND is REAL
*> The reciprocal of the condition number of the matrix A,
*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
*> estimate of the 1-norm of inv(A) computed in this routine.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complexHEcomputational
*
*> \par Contributors:
* ==================
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE CHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, KASE
REAL AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL CHETRS_ROOK, CLACN2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CHECON_ROOK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
*
CALL CHETRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of CHECON_ROOK
*
END

295
lapack-netlib/SRC/chesv_rook.f Normal file
View File

@ -0,0 +1,295 @@
*> \brief \b CHESV_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using the bounded Bunch-Kaufman ("rook") diagonal pivoting method
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHESV_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chesv_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chesv_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chesv_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHESV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
* LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHESV_ROOK computes the solution to a complex system of linear equations
*> A * X = B,
*> where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
*> matrices.
*>
*> The bounded Bunch-Kaufman ("rook") diagonal pivoting method is used
*> to factor A as
*> A = U * D * U**T, if UPLO = 'U', or
*> A = L * D * L**T, if UPLO = 'L',
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is Hermitian and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.
*>
*> CHETRF_ROOK is called to compute the factorization of a complex
*> Hermition matrix A using the bounded Bunch-Kaufman ("rook") diagonal
*> pivoting method.
*>
*> The factored form of A is then used to solve the system
*> of equations A * X = B by calling CHETRS_ROOK (uses BLAS 2).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of linear equations, i.e., the order of the
*> matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the block diagonal matrix D and the
*> multipliers used to obtain the factor U or L from the
*> factorization A = U*D*U**H or A = L*D*L**H as computed by
*> CHETRF_ROOK.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> Only the last KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> Only the first KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS right hand side matrix B.
*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of WORK. LWORK >= 1, and for best performance
*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for
*> CHETRF_ROOK.
*> for LWORK < N, TRS will be done with Level BLAS 2
*> for LWORK >= N, TRS will be done with Level BLAS 3
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular, so the solution could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complexHEsolve
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
*
* =====================================================================
SUBROUTINE CHESV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
$ LWORK, INFO )
*
* -- LAPACK driver routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, LWORK, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, CHETRF_ROOK, CHETRS_ROOK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'CHETRF_ROOK', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CHESV_ROOK ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Compute the factorization A = U*D*U**H or A = L*D*L**H.
*
CALL CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
* Solve with TRS ( Use Level BLAS 2)
*
CALL CHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
END IF
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of CHESV_ROOK
*
END

39
lapack-netlib/SRC/chetf2.f
View File

@ -1,4 +1,4 @@
*> \brief \b CHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm).
*> \brief \b CHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm calling Level 2 BLAS).
*
* =========== DOCUMENTATION ===========
*
@ -90,13 +90,22 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*>
*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
@ -118,7 +127,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup complexHEcomputational
*
@ -177,10 +186,10 @@
* =====================================================================
SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@ -268,7 +277,8 @@
ABSAKK = ABS( REAL( A( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, A( 1, K ), 1 )
@ -279,7 +289,8 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
*
* Column K is zero or contains a NaN: set INFO and continue
* Column K is or underflow, or contains a NaN:
* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@ -450,7 +461,8 @@
ABSAKK = ABS( REAL( A( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 )
@ -461,7 +473,8 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
*
* Column K is zero or contains a NaN: set INFO and continue
* Column K is zero or underflow, contains a NaN:
* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K

910
lapack-netlib/SRC/chetf2_rook.f Normal file
View File

@ -0,0 +1,910 @@
*> \brief \b CHETF2_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHETF2_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetf2_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetf2_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetf2_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHETF2_ROOK computes the factorization of a complex Hermitian matrix A
*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
*>
*> A = U*D*U**H or A = L*D*L**H
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, U**H is the conjugate transpose of U, and D is
*> Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
*>
*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> Hermitian matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L (see below for further details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the k-th argument had an illegal value
*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular, and division by zero will occur if it
*> is used to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complexHEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**H, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**H, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> 01-01-96 - Based on modifications by
*> J. Lewis, Boeing Computer Services Company
*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*> \endverbatim
*
* =====================================================================
SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * )
* ..
*
* ======================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL DONE, UPPER
INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP,
$ P
REAL ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, STEMP,
$ ROWMAX, TT, SFMIN
COMPLEX D12, D21, T, WK, WKM1, WKP1, Z
* ..
* .. External Functions ..
*
LOGICAL LSAME
INTEGER ICAMAX
REAL SLAMCH, SLAPY2
EXTERNAL LSAME, ICAMAX, SLAMCH, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, CSSCAL, CHER, CSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, REAL, SQRT
* ..
* .. Statement Functions ..
REAL CABS1
* ..
* .. Statement Function definitions ..
CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CHETF2_ROOK', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
* Compute machine safe minimum
*
SFMIN = SLAMCH( 'S' )
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**H using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 70
KSTEP = 1
P = K
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( REAL( A( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, A( 1, K ), 1 )
COLMAX = CABS1( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = REAL( A( K, K ) )
ELSE
*
* ============================================================
*
* BEGIN pivot search
*
* Case(1)
* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
* (used to handle NaN and Inf)
*
IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
ELSE
*
DONE = .FALSE.
*
* Loop until pivot found
*
12 CONTINUE
*
* BEGIN pivot search loop body
*
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine both ROWMAX and JMAX.
*
IF( IMAX.NE.K ) THEN
JMAX = IMAX + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ),
$ LDA )
ROWMAX = CABS1( A( IMAX, JMAX ) )
ELSE
ROWMAX = ZERO
END IF
*
IF( IMAX.GT.1 ) THEN
ITEMP = ICAMAX( IMAX-1, A( 1, IMAX ), 1 )
STEMP = CABS1( A( ITEMP, IMAX ) )
IF( STEMP.GT.ROWMAX ) THEN
ROWMAX = STEMP
JMAX = ITEMP
END IF
END IF
*
* Case(2)
* Equivalent to testing for
* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
* (used to handle NaN and Inf)
*
IF( .NOT.( ABS( REAL( A( IMAX, IMAX ) ) )
$ .LT.ALPHA*ROWMAX ) ) THEN
*
* interchange rows and columns K and IMAX,
* use 1-by-1 pivot block
*
KP = IMAX
DONE = .TRUE.
*
* Case(3)
* Equivalent to testing for ROWMAX.EQ.COLMAX,
* (used to handle NaN and Inf)
*
ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
$ THEN
*
* interchange rows and columns K-1 and IMAX,
* use 2-by-2 pivot block
*
KP = IMAX
KSTEP = 2
DONE = .TRUE.
*
* Case(4)
ELSE
*
* Pivot not found: set params and repeat
*
P = IMAX
COLMAX = ROWMAX
IMAX = JMAX
END IF
*
* END pivot search loop body
*
IF( .NOT.DONE ) GOTO 12
*
END IF
*
* END pivot search
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
*
* For only a 2x2 pivot, interchange rows and columns K and P
* in the leading submatrix A(1:k,1:k)
*
IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
* (1) Swap columnar parts
IF( P.GT.1 )
$ CALL CSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
* (2) Swap and conjugate middle parts
DO 14 J = P + 1, K - 1
T = CONJG( A( J, K ) )
A( J, K ) = CONJG( A( P, J ) )
A( P, J ) = T
14 CONTINUE
* (3) Swap and conjugate corner elements at row-col interserction
A( P, K ) = CONJG( A( P, K ) )
* (4) Swap diagonal elements at row-col intersection
R1 = REAL( A( K, K ) )
A( K, K ) = REAL( A( P, P ) )
A( P, P ) = R1
END IF
*
* For both 1x1 and 2x2 pivots, interchange rows and
* columns KK and KP in the leading submatrix A(1:k,1:k)
*
IF( KP.NE.KK ) THEN
* (1) Swap columnar parts
IF( KP.GT.1 )
$ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
* (2) Swap and conjugate middle parts
DO 15 J = KP + 1, KK - 1
T = CONJG( A( J, KK ) )
A( J, KK ) = CONJG( A( KP, J ) )
A( KP, J ) = T
15 CONTINUE
* (3) Swap and conjugate corner elements at row-col interserction
A( KP, KK ) = CONJG( A( KP, KK ) )
* (4) Swap diagonal elements at row-col intersection
R1 = REAL( A( KK, KK ) )
A( KK, KK ) = REAL( A( KP, KP ) )
A( KP, KP ) = R1
*
IF( KSTEP.EQ.2 ) THEN
* (*) Make sure that diagonal element of pivot is real
A( K, K ) = REAL( A( K, K ) )
* (5) Swap row elements
T = A( K-1, K )
A( K-1, K ) = A( KP, K )
A( KP, K ) = T
END IF
ELSE
* (*) Make sure that diagonal element of pivot is real
A( K, K ) = REAL( A( K, K ) )
IF( KSTEP.EQ.2 )
$ A( K-1, K-1 ) = REAL( A( K-1, K-1 ) )
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
IF( K.GT.1 ) THEN
*
* Perform a rank-1 update of A(1:k-1,1:k-1) and
* store U(k) in column k
*
IF( ABS( REAL( A( K, K ) ) ).GE.SFMIN ) THEN
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
* A := A - U(k)*D(k)*U(k)**T
* = A - W(k)*1/D(k)*W(k)**T
*
D11 = ONE / REAL( A( K, K ) )
CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
*
* Store U(k) in column k
*
CALL CSSCAL( K-1, D11, A( 1, K ), 1 )
ELSE
*
* Store L(k) in column K
*
D11 = REAL( A( K, K ) )
DO 16 II = 1, K - 1
A( II, K ) = A( II, K ) / D11
16 CONTINUE
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
* A := A - U(k)*D(k)*U(k)**T
* = A - W(k)*(1/D(k))*W(k)**T
* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
*
CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
END IF
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
*
* and store L(k) and L(k+1) in columns k and k+1
*
IF( K.GT.2 ) THEN
* D = |A12|
D = SLAPY2( REAL( A( K-1, K ) ),
$ AIMAG( A( K-1, K ) ) )
D11 = A( K, K ) / D
D22 = A( K-1, K-1 ) / D
D12 = A( K-1, K ) / D
TT = ONE / ( D11*D22-ONE )
*
DO 30 J = K - 2, 1, -1
*
* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
*
WKM1 = TT*( D11*A( J, K-1 )-CONJG( D12 )*
$ A( J, K ) )
WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) )
*
* Perform a rank-2 update of A(1:k-2,1:k-2)
*
DO 20 I = J, 1, -1
A( I, J ) = A( I, J ) -
$ ( A( I, K ) / D )*CONJG( WK ) -
$ ( A( I, K-1 ) / D )*CONJG( WKM1 )
20 CONTINUE
*
* Store U(k) and U(k-1) in cols k and k-1 for row J
*
A( J, K ) = WK / D
A( J, K-1 ) = WKM1 / D
* (*) Make sure that diagonal element of pivot is real
A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO )
*
30 CONTINUE
*
END IF
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -P
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**H using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 70
KSTEP = 1
P = K
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( REAL( A( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 )
COLMAX = CABS1( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = REAL( A( K, K ) )
ELSE
*
* ============================================================
*
* BEGIN pivot search
*
* Case(1)
* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
* (used to handle NaN and Inf)
*
IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
ELSE
*
DONE = .FALSE.
*
* Loop until pivot found
*
42 CONTINUE
*
* BEGIN pivot search loop body
*
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine both ROWMAX and JMAX.
*
IF( IMAX.NE.K ) THEN
JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA )
ROWMAX = CABS1( A( IMAX, JMAX ) )
ELSE
ROWMAX = ZERO
END IF
*
IF( IMAX.LT.N ) THEN
ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ),
$ 1 )
STEMP = CABS1( A( ITEMP, IMAX ) )
IF( STEMP.GT.ROWMAX ) THEN
ROWMAX = STEMP
JMAX = ITEMP
END IF
END IF
*
* Case(2)
* Equivalent to testing for
* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
* (used to handle NaN and Inf)
*
IF( .NOT.( ABS( REAL( A( IMAX, IMAX ) ) )
$ .LT.ALPHA*ROWMAX ) ) THEN
*
* interchange rows and columns K and IMAX,
* use 1-by-1 pivot block
*
KP = IMAX
DONE = .TRUE.
*
* Case(3)
* Equivalent to testing for ROWMAX.EQ.COLMAX,
* (used to handle NaN and Inf)
*
ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
$ THEN
*
* interchange rows and columns K+1 and IMAX,
* use 2-by-2 pivot block
*
KP = IMAX
KSTEP = 2
DONE = .TRUE.
*
* Case(4)
ELSE
*
* Pivot not found: set params and repeat
*
P = IMAX
COLMAX = ROWMAX
IMAX = JMAX
END IF
*
*
* END pivot search loop body
*
IF( .NOT.DONE ) GOTO 42
*
END IF
*
* END pivot search
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
* For only a 2x2 pivot, interchange rows and columns K and P
* in the trailing submatrix A(k:n,k:n)
*
IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
* (1) Swap columnar parts
IF( P.LT.N )
$ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
* (2) Swap and conjugate middle parts
DO 44 J = K + 1, P - 1
T = CONJG( A( J, K ) )
A( J, K ) = CONJG( A( P, J ) )
A( P, J ) = T
44 CONTINUE
* (3) Swap and conjugate corner elements at row-col interserction
A( P, K ) = CONJG( A( P, K ) )
* (4) Swap diagonal elements at row-col intersection
R1 = REAL( A( K, K ) )
A( K, K ) = REAL( A( P, P ) )
A( P, P ) = R1
END IF
*
* For both 1x1 and 2x2 pivots, interchange rows and
* columns KK and KP in the trailing submatrix A(k:n,k:n)
*
IF( KP.NE.KK ) THEN
* (1) Swap columnar parts
IF( KP.LT.N )
$ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
* (2) Swap and conjugate middle parts
DO 45 J = KK + 1, KP - 1
T = CONJG( A( J, KK ) )
A( J, KK ) = CONJG( A( KP, J ) )
A( KP, J ) = T
45 CONTINUE
* (3) Swap and conjugate corner elements at row-col interserction
A( KP, KK ) = CONJG( A( KP, KK ) )
* (4) Swap diagonal elements at row-col intersection
R1 = REAL( A( KK, KK ) )
A( KK, KK ) = REAL( A( KP, KP ) )
A( KP, KP ) = R1
*
IF( KSTEP.EQ.2 ) THEN
* (*) Make sure that diagonal element of pivot is real
A( K, K ) = REAL( A( K, K ) )
* (5) Swap row elements
T = A( K+1, K )
A( K+1, K ) = A( KP, K )
A( KP, K ) = T
END IF
ELSE
* (*) Make sure that diagonal element of pivot is real
A( K, K ) = REAL( A( K, K ) )
IF( KSTEP.EQ.2 )
$ A( K+1, K+1 ) = REAL( A( K+1, K+1 ) )
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k of A now holds
*
* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) and
* store L(k) in column k
*
* Handle division by a small number
*
IF( ABS( REAL( A( K, K ) ) ).GE.SFMIN ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
* A := A - L(k)*D(k)*L(k)**T
* = A - W(k)*(1/D(k))*W(k)**T
*
D11 = ONE / REAL( A( K, K ) )
CALL CHER( UPLO, N-K, -D11, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
*
* Store L(k) in column k
*
CALL CSSCAL( N-K, D11, A( K+1, K ), 1 )
ELSE
*
* Store L(k) in column k
*
D11 = REAL( A( K, K ) )
DO 46 II = K + 1, N
A( II, K ) = A( II, K ) / D11
46 CONTINUE
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
* A := A - L(k)*D(k)*L(k)**T
* = A - W(k)*(1/D(k))*W(k)**T
* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
*
CALL CHER( UPLO, N-K, -D11, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
END IF
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
*
* and store L(k) and L(k+1) in columns k and k+1
*
IF( K.LT.N-1 ) THEN
* D = |A21|
D = SLAPY2( REAL( A( K+1, K ) ),
$ AIMAG( A( K+1, K ) ) )
D11 = REAL( A( K+1, K+1 ) ) / D
D22 = REAL( A( K, K ) ) / D
D21 = A( K+1, K ) / D
TT = ONE / ( D11*D22-ONE )
*
DO 60 J = K + 2, N
*
* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
*
WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) )
WKP1 = TT*( D22*A( J, K+1 )-CONJG( D21 )*
$ A( J, K ) )
*
* Perform a rank-2 update of A(k+2:n,k+2:n)
*
DO 50 I = J, N
A( I, J ) = A( I, J ) -
$ ( A( I, K ) / D )*CONJG( WK ) -
$ ( A( I, K+1 ) / D )*CONJG( WKP1 )
50 CONTINUE
*
* Store L(k) and L(k+1) in cols k and k+1 for row J
*
A( J, K ) = WK / D
A( J, K+1 ) = WKP1 / D
* (*) Make sure that diagonal element of pivot is real
A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO )
*
60 CONTINUE
*
END IF
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -P
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 40
*
END IF
*
70 CONTINUE
*
RETURN
*
* End of CHETF2_ROOK
*
END

397
lapack-netlib/SRC/chetrf_rook.f Normal file
View File

@ -0,0 +1,397 @@
*> \brief \b CHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHETRF_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetrf_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetrf_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetrf_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHETRF_ROOK computes the factorization of a comlex Hermitian matrix A
*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
*> The form of the factorization is
*>
*> A = U*D*U**T or A = L*D*L**T
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is Hermitian and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.
*>
*> This is the blocked version of the algorithm, calling Level 3 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L (see below for further details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> Only the last KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> Only the first KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (MAX(1,LWORK)).
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of WORK. LWORK >=1. For best performance
*> LWORK >= N*NB, where NB is the block size returned by ILAENV.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular, and division by zero will occur if it
*> is used to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complexHEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**T, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**T, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL CLAHEF_ROOK, CHETF2_ROOK, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size
*
NB = ILAENV( 1, 'CHETRF_ROOK', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CHETRF_ROOK', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = MAX( 2, ILAENV( 2, 'CHETRF_ROOK',
$ UPLO, N, -1, -1, -1 ) )
END IF
ELSE
IWS = 1
END IF
IF( NB.LT.NBMIN )
$ NB = N
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**T using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* KB, where KB is the number of columns factorized by CLAHEF_ROOK;
* KB is either NB or NB-1, or K for the last block
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 40
*
IF( K.GT.NB ) THEN
*
* Factorize columns k-kb+1:k of A and use blocked code to
* update columns 1:k-kb
*
CALL CLAHEF_ROOK( UPLO, K, NB, KB, A, LDA,
$ IPIV, WORK, LDWORK, IINFO )
ELSE
*
* Use unblocked code to factorize columns 1:k of A
*
CALL CHETF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO )
KB = K
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* No need to adjust IPIV
*
* Decrease K and return to the start of the main loop
*
K = K - KB
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**T using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* KB, where KB is the number of columns factorized by CLAHEF_ROOK;
* KB is either NB or NB-1, or N-K+1 for the last block
*
K = 1
20 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 40
*
IF( K.LE.N-NB ) THEN
*
* Factorize columns k:k+kb-1 of A and use blocked code to
* update columns k+kb:n
*
CALL CLAHEF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
$ IPIV( K ), WORK, LDWORK, IINFO )
ELSE
*
* Use unblocked code to factorize columns k:n of A
*
CALL CHETF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
$ IINFO )
KB = N - K + 1
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + K - 1
*
* Adjust IPIV
*
DO 30 J = K, K + KB - 1
IF( IPIV( J ).GT.0 ) THEN
IPIV( J ) = IPIV( J ) + K - 1
ELSE
IPIV( J ) = IPIV( J ) - K + 1
END IF
30 CONTINUE
*
* Increase K and return to the start of the main loop
*
K = K + KB
GO TO 20
*
END IF
*
40 CONTINUE
WORK( 1 ) = LWKOPT
RETURN
*
* End of CHETRF_ROOK
*
END

516
lapack-netlib/SRC/chetri_rook.f Normal file
View File

@ -0,0 +1,516 @@
*> \brief \b CHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHETRI_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetri_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetri_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetri_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHETRI_ROOK computes the inverse of a complex Hermitian indefinite matrix
*> A using the factorization A = U*D*U**H or A = L*D*L**H computed by
*> CHETRF_ROOK.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**H;
*> = 'L': Lower triangular, form is A = L*D*L**H.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the block diagonal matrix D and the multipliers
*> used to obtain the factor U or L as computed by CHETRF_ROOK.
*>
*> On exit, if INFO = 0, the (Hermitian) inverse of the original
*> matrix. If UPLO = 'U', the upper triangular part of the
*> inverse is formed and the part of A below the diagonal is not
*> referenced; if UPLO = 'L' the lower triangular part of the
*> inverse is formed and the part of A above the diagonal is
*> not referenced.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by CHETRF_ROOK.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
*> inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complexHEcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*> \endverbatim
*
* =====================================================================
SUBROUTINE CHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
COMPLEX CONE, CZERO
PARAMETER ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ),
$ CZERO = ( 0.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KP, KSTEP
REAL AK, AKP1, D, T
COMPLEX AKKP1, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX CDOTC
EXTERNAL LSAME, CDOTC
* ..
* .. External Subroutines ..
EXTERNAL CCOPY, CHEMV, CSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, CONJG, MAX, REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CHETRI_ROOK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
$ RETURN
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U**H.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 70
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / REAL( A( K, K ) )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - REAL( CDOTC( K-1, WORK, 1, A( 1,
$ K ), 1 ) )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( A( K, K+1 ) )
AK = REAL( A( K, K ) ) / T
AKP1 = REAL( A( K+1, K+1 ) ) / T
AKKP1 = A( K, K+1 ) / T
D = T*( AK*AKP1-ONE )
A( K, K ) = AKP1 / D
A( K+1, K+1 ) = AK / D
A( K, K+1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - REAL( CDOTC( K-1, WORK, 1, A( 1,
$ K ), 1 ) )
A( K, K+1 ) = A( K, K+1 ) -
$ CDOTC( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
CALL CCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
$ A( 1, K+1 ), 1 )
A( K+1, K+1 ) = A( K+1, K+1 ) -
$ REAL( CDOTC( K-1, WORK, 1, A( 1, K+1 ),
$ 1 ) )
END IF
KSTEP = 2
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* Interchange rows and columns K and IPIV(K) in the leading
* submatrix A(1:k,1:k)
*
KP = IPIV( K )
IF( KP.NE.K ) THEN
*
IF( KP.GT.1 )
$ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
*
DO 40 J = KP + 1, K - 1
TEMP = CONJG( A( J, K ) )
A( J, K ) = CONJG( A( KP, J ) )
A( KP, J ) = TEMP
40 CONTINUE
*
A( KP, K ) = CONJG( A( KP, K ) )
*
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
ELSE
*
* Interchange rows and columns K and K+1 with -IPIV(K) and
* -IPIV(K+1) in the leading submatrix A(k+1:n,k+1:n)
*
* (1) Interchange rows and columns K and -IPIV(K)
*
KP = -IPIV( K )
IF( KP.NE.K ) THEN
*
IF( KP.GT.1 )
$ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
*
DO 50 J = KP + 1, K - 1
TEMP = CONJG( A( J, K ) )
A( J, K ) = CONJG( A( KP, J ) )
A( KP, J ) = TEMP
50 CONTINUE
*
A( KP, K ) = CONJG( A( KP, K ) )
*
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
*
TEMP = A( K, K+1 )
A( K, K+1 ) = A( KP, K+1 )
A( KP, K+1 ) = TEMP
END IF
*
* (2) Interchange rows and columns K+1 and -IPIV(K+1)
*
K = K + 1
KP = -IPIV( K )
IF( KP.NE.K ) THEN
*
IF( KP.GT.1 )
$ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
*
DO 60 J = KP + 1, K - 1
TEMP = CONJG( A( J, K ) )
A( J, K ) = CONJG( A( KP, J ) )
A( KP, J ) = TEMP
60 CONTINUE
*
A( KP, K ) = CONJG( A( KP, K ) )
*
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
END IF
*
K = K + 1
GO TO 30
70 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L**H.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
80 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 120
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / REAL( A( K, K ) )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
$ 1, CZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - REAL( CDOTC( N-K, WORK, 1,
$ A( K+1, K ), 1 ) )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( A( K, K-1 ) )
AK = REAL( A( K-1, K-1 ) ) / T
AKP1 = REAL( A( K, K ) ) / T
AKKP1 = A( K, K-1 ) / T
D = T*( AK*AKP1-ONE )
A( K-1, K-1 ) = AKP1 / D
A( K, K ) = AK / D
A( K, K-1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
$ 1, CZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - REAL( CDOTC( N-K, WORK, 1,
$ A( K+1, K ), 1 ) )
A( K, K-1 ) = A( K, K-1 ) -
$ CDOTC( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
$ 1 )
CALL CCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
$ 1, CZERO, A( K+1, K-1 ), 1 )
A( K-1, K-1 ) = A( K-1, K-1 ) -
$ REAL( CDOTC( N-K, WORK, 1, A( K+1, K-1 ),
$ 1 ) )
END IF
KSTEP = 2
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* Interchange rows and columns K and IPIV(K) in the trailing
* submatrix A(k:n,k:n)
*
KP = IPIV( K )
IF( KP.NE.K ) THEN
*
IF( KP.LT.N )
$ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
*
DO 90 J = K + 1, KP - 1
TEMP = CONJG( A( J, K ) )
A( J, K ) = CONJG( A( KP, J ) )
A( KP, J ) = TEMP
90 CONTINUE
*
A( KP, K ) = CONJG( A( KP, K ) )
*
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
ELSE
*
* Interchange rows and columns K and K-1 with -IPIV(K) and
* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
*
* (1) Interchange rows and columns K and -IPIV(K)
*
KP = -IPIV( K )
IF( KP.NE.K ) THEN
*
IF( KP.LT.N )
$ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
*
DO 100 J = K + 1, KP - 1
TEMP = CONJG( A( J, K ) )
A( J, K ) = CONJG( A( KP, J ) )
A( KP, J ) = TEMP
100 CONTINUE
*
A( KP, K ) = CONJG( A( KP, K ) )
*
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
*
TEMP = A( K, K-1 )
A( K, K-1 ) = A( KP, K-1 )
A( KP, K-1 ) = TEMP
END IF
*
* (2) Interchange rows and columns K-1 and -IPIV(K-1)
*
K = K - 1
KP = -IPIV( K )
IF( KP.NE.K ) THEN
*
IF( KP.LT.N )
$ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
*
DO 110 J = K + 1, KP - 1
TEMP = CONJG( A( J, K ) )
A( J, K ) = CONJG( A( KP, J ) )
A( KP, J ) = TEMP
110 CONTINUE
*
A( KP, K ) = CONJG( A( KP, K ) )
*
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
END IF
*
K = K - 1
GO TO 80
120 CONTINUE
END IF
*
RETURN
*
* End of CHETRI_ROOK
*
END

503
lapack-netlib/SRC/chetrs_rook.f Normal file
View File

@ -0,0 +1,503 @@
*> \brief \b CHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges)
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHETRS_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetrs_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetrs_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetrs_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHETRS_ROOK solves a system of linear equations A*X = B with a complex
*> Hermitian matrix A using the factorization A = U*D*U**H or
*> A = L*D*L**H computed by CHETRF_ROOK.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**H;
*> = 'L': Lower triangular, form is A = L*D*L**H.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by CHETRF_ROOK.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by CHETRF_ROOK.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension (LDB,NRHS)
*> On entry, the right hand side matrix B.
*> On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complexHEcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE CHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
$ INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KP
REAL S
COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL CGEMV, CGERU, CLACGV, CSSCAL, CSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG, MAX, REAL
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CHETRS_ROOK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U**H.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL CGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
S = REAL( ONE ) / REAL( A( K, K ) )
CALL CSSCAL( NRHS, S, B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1)
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K-1)
IF( KP.NE.K-1 )
$ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
CALL CGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
CALL CGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
$ LDB, B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K-1, K )
AKM1 = A( K-1, K-1 ) / AKM1K
AK = A( K, K ) / CONJG( AKM1K )
DENOM = AKM1*AK - ONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / CONJG( AKM1K )
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U**H *X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U**H(K)), where U(K) is the transformation
* stored in column K of A.
*
IF( K.GT.1 ) THEN
CALL CLACGV( NRHS, B( K, 1 ), LDB )
CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
$ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
CALL CLACGV( NRHS, B( K, 1 ), LDB )
END IF
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.GT.1 ) THEN
CALL CLACGV( NRHS, B( K, 1 ), LDB )
CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
$ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
CALL CLACGV( NRHS, B( K, 1 ), LDB )
*
CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
$ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
END IF
*
* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1)
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K+1 )
IF( KP.NE.K+1 )
$ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L**H.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL CGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
S = REAL( ONE ) / REAL( A( K, K ) )
CALL CSSCAL( NRHS, S, B( K, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1)
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K+1 )
IF( KP.NE.K+1 )
$ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL CGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL CGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K+1, K )
AKM1 = A( K, K ) / CONJG( AKM1K )
AK = A( K+1, K+1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / CONJG( AKM1K )
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L**H *X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L**H(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N ) THEN
CALL CLACGV( NRHS, B( K, 1 ), LDB )
CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
$ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
$ B( K, 1 ), LDB )
CALL CLACGV( NRHS, B( K, 1 ), LDB )
END IF
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL CLACGV( NRHS, B( K, 1 ), LDB )
CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
$ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
$ B( K, 1 ), LDB )
CALL CLACGV( NRHS, B( K, 1 ), LDB )
*
CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
$ B( K+1, 1 ), LDB, A( K+1, K-1 ), 1, ONE,
$ B( K-1, 1 ), LDB )
CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
END IF
*
* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1)
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K-1 )
IF( KP.NE.K-1 )
$ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of CHETRS_ROOK
*
END

16
lapack-netlib/SRC/chsein.f
View File

@ -104,6 +104,7 @@
*> \verbatim
*> H is COMPLEX array, dimension (LDH,N)
*> The upper Hessenberg matrix H.
*> If a NaN is detected in H, the routine will return with INFO=-6.
*> \endverbatim
*>
*> \param[in] LDH
@ -225,7 +226,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@ -244,10 +245,10 @@
$ LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL,
$ IFAILR, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER EIGSRC, INITV, SIDE
@ -276,9 +277,9 @@
COMPLEX CDUM, WK
* ..
* .. External Functions ..
LOGICAL LSAME
LOGICAL LSAME, SISNAN
REAL CLANHS, SLAMCH
EXTERNAL LSAME, CLANHS, SLAMCH
EXTERNAL LSAME, CLANHS, SLAMCH, SISNAN
* ..
* .. External Subroutines ..
EXTERNAL CLAEIN, XERBLA
@ -399,7 +400,10 @@
* has not ben computed before.
*
HNORM = CLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, RWORK )
IF( HNORM.GT.RZERO ) THEN
IF( SISNAN( HNORM ) ) THEN
INFO = -6
RETURN
ELSE IF( (HNORM.GT.RZERO) ) THEN
EPS3 = HNORM*ULP
ELSE
EPS3 = SMLNUM

8
lapack-netlib/SRC/chseqr.f
View File

@ -43,7 +43,7 @@
*> Optionally Z may be postmultiplied into an input unitary
*> matrix Q so that this routine can give the Schur factorization
*> of a matrix A which has been reduced to the Hessenberg form H
*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
*> \endverbatim
*
* Arguments:
@ -216,7 +216,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@ -299,10 +299,10 @@
SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
$ WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N

10
lapack-netlib/SRC/cla_lin_berr.f
View File

@ -67,14 +67,14 @@
*>
*> \param[in] RES
*> \verbatim
*> RES is DOUBLE PRECISION array, dimension (N,NRHS)
*> RES is REAL array, dimension (N,NRHS)
*> The residual matrix, i.e., the matrix R in the relative backward
*> error formula above.
*> \endverbatim
*>
*> \param[in] AYB
*> \verbatim
*> AYB is DOUBLE PRECISION array, dimension (N, NRHS)
*> AYB is REAL array, dimension (N, NRHS)
*> The denominator in the relative backward error formula above, i.e.,
*> the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B
*> are from iterative refinement (see cla_gerfsx_extended.f).
@ -94,17 +94,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
* =====================================================================
SUBROUTINE CLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
INTEGER N, NZ, NRHS

349
lapack-netlib/SRC/clahef.f
View File

@ -1,4 +1,4 @@
*> \brief \b CLAHEF computes a partial factorization of a complex Hermitian indefinite matrix, using the diagonal pivoting method.
*> \brief \b CLAHEF computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
*
* =========== DOCUMENTATION ===========
*
@ -110,16 +110,26 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*> If UPLO = 'U', only the last KB elements of IPIV are set;
*> if UPLO = 'L', only the first KB elements are set.
*>
*> If UPLO = 'U':
*> Only the last KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*>
*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> Only the first KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
@ -150,17 +160,27 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup complexHEcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*> \endverbatim
*
* =====================================================================
SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@ -219,17 +239,20 @@
* for use in updating A11 (note that conjg(W) is actually stored)
*
* K is the main loop index, decreasing from N in steps of 1 or 2
*
* KW is the column of W which corresponds to column K of A
*
K = N
10 CONTINUE
*
* KW is the column of W which corresponds to column K of A
*
KW = NB + K - N
*
* Exit from loop
*
IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
$ GO TO 30
*
KSTEP = 1
*
* Copy column K of A to column KW of W and update it
*
@ -240,8 +263,6 @@
$ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
W( K, KW ) = REAL( W( K, KW ) )
END IF
*
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
@ -249,7 +270,8 @@
ABSAKK = ABS( REAL( W( K, KW ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, W( 1, KW ), 1 )
@ -260,13 +282,19 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = REAL( A( K, K ) )
ELSE
*
* ============================================================
*
* BEGIN pivot search
*
* Case(1)
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
@ -274,6 +302,9 @@
KP = K
ELSE
*
* BEGIN pivot search along IMAX row
*
*
* Copy column IMAX to column KW-1 of W and update it
*
CALL CCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
@ -289,7 +320,8 @@
END IF
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
* element in row IMAX, and ROWMAX is its absolute value.
* Determine only ROWMAX.
*
JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
ROWMAX = CABS1( W( JMAX, KW-1 ) )
@ -298,11 +330,14 @@
ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, KW-1 ) ) )
END IF
*
* Case(2)
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
* Case(3)
ELSE IF( ABS( REAL( W( IMAX, KW-1 ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
@ -311,9 +346,11 @@
*
KP = IMAX
*
* copy column KW-1 of W to column KW
* copy column KW-1 of W to column KW of W
*
CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
*
* Case(4)
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
@ -322,27 +359,48 @@
KP = IMAX
KSTEP = 2
END IF
*
*
* END pivot search along IMAX row
*
END IF
*
* END pivot search
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
*
* KKW is the column of W which corresponds to column KK of A
*
KKW = NB + KK - N
*
* Updated column KP is already stored in column KKW of W
* Interchange rows and columns KP and KK.
* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
* Copy non-updated column KK to column KP of submatrix A
* at step K. No need to copy element into column K
* (or K and K-1 for 2-by-2 pivot) of A, since these columns
* will be later overwritten.
*
A( KP, KP ) = REAL( A( KK, KK ) )
CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL CLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
IF( KP.GT.1 )
$ CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
* Interchange rows KK and KP in last KK columns of A and W
* Interchange rows KK and KP in last K+1 to N columns of A
* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
* later overwritten). Interchange rows KK and KP
* in last KKW to NB columns of W.
*
IF( KK.LT.N )
$ CALL CSWAP( N-KK, A( KK, KK+1 ), LDA, A( KP, KK+1 ),
IF( K.LT.N )
$ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
$ LDA )
CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
@ -350,40 +408,108 @@
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column KW of W now holds
* 1-by-1 pivot block D(k): column kw of W now holds
*
* W(k) = U(k)*D(k)
* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
* Store U(k) in column k of A
* (1) Store subdiag. elements of column U(k)
* and 1-by-1 block D(k) in column k of A.
* (NOTE: Diagonal element U(k,k) is a UNIT element
* and not stored)
* A(k,k) := D(k,k) = W(k,kw)
* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
* (NOTE: No need to use for Hermitian matrix
* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
* element D(k,k) from W (potentially saves only one load))
CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
IF( K.GT.1 ) THEN
*
* (NOTE: No need to check if A(k,k) is NOT ZERO,
* since that was ensured earlier in pivot search:
* case A(k,k) = 0 falls into 2x2 pivot case(4))
*
R1 = ONE / REAL( A( K, K ) )
CALL CSSCAL( K-1, R1, A( 1, K ), 1 )
*
* Conjugate W(k)
* (2) Conjugate column W(kw)
*
CALL CLACGV( K-1, W( 1, KW ), 1 )
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
* hold
* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
* block D(k-1:k,k-1:k) in columns k-1 and k of A.
* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
* block and not stored)
* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
* Store U(k) and U(k-1) in columns k and k-1 of A
* Factor out the columns of the inverse of 2-by-2 pivot
* block D, so that each column contains 1, to reduce the
* number of FLOPS when we multiply panel
* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
*
* D**(-1) = ( d11 cj(d21) )**(-1) =
* ( d21 d22 )
*
* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
* ( (-d21) ( d11 ) )
*
* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
*
* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
* ( ( -1 ) ( d11/conj(d21) ) )
*
* = 1/(|d21|**2) * 1/(D22*D11-1) *
*
* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = ( conj(D21)*( D11 ) D21*( -1 ) )
* ( ( -1 ) ( D22 ) ),
*
* where D11 = d22/d21,
* D22 = d11/conj(d21),
* D21 = T/d21,
* T = 1/(D22*D11-1).
*
* (NOTE: No need to check for division by ZERO,
* since that was ensured earlier in pivot search:
* (a) d21 != 0, since in 2x2 pivot case(4)
* |d21| should be larger than |d11| and |d22|;
* (b) (D22*D11 - 1) != 0, since from (a),
* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / CONJG( D21 )
D22 = W( K-1, KW-1 ) / D21
T = ONE / ( REAL( D11*D22 )-ONE )
D21 = T / D21
*
* Update elements in columns A(k-1) and A(k) as
* dot products of rows of ( W(kw-1) W(kw) ) and columns
* of D**(-1)
*
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = CONJG( D21 )*
@ -397,11 +523,13 @@
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
*
* Conjugate W(k) and W(k-1)
* (2) Conjugate columns W(kw) and W(kw-1)
*
CALL CLACGV( K-1, W( 1, KW ), 1 )
CALL CLACGV( K-2, W( 1, KW-1 ), 1 )
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
@ -448,16 +576,24 @@
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
* in columns k+1:n
* in of rows in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
*
* Undo the interchanges (if any) of rows J and JP
* at each step J
*
* (Here, J is a diagonal index)
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
* (Here, J is a diagonal index)
J = J + 1
END IF
* (NOTE: Here, J is used to determine row length. Length N-J+1
* of the rows to swap back doesn't include diagonal element)
J = J + 1
IF( JP.NE.JJ .AND. J.LE.N )
$ CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
@ -483,6 +619,8 @@
*
IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
$ GO TO 90
*
KSTEP = 1
*
* Copy column K of A to column K of W and update it
*
@ -492,8 +630,6 @@
CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA,
$ W( K, 1 ), LDW, CONE, W( K, K ), 1 )
W( K, K ) = REAL( W( K, K ) )
*
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
@ -501,7 +637,8 @@
ABSAKK = ABS( REAL( W( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 )
@ -512,13 +649,19 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = REAL( A( K, K ) )
ELSE
*
* ============================================================
*
* BEGIN pivot search
*
* Case(1)
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
@ -526,6 +669,9 @@
KP = K
ELSE
*
* BEGIN pivot search along IMAX row
*
*
* Copy column IMAX to column K+1 of W and update it
*
CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
@ -540,7 +686,8 @@
W( IMAX, K+1 ) = REAL( W( IMAX, K+1 ) )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
* element in row IMAX, and ROWMAX is its absolute value.
* Determine only ROWMAX.
*
JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 )
ROWMAX = CABS1( W( JMAX, K+1 ) )
@ -549,11 +696,14 @@
ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, K+1 ) ) )
END IF
*
* Case(2)
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
* Case(3)
ELSE IF( ABS( REAL( W( IMAX, K+1 ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
@ -562,9 +712,11 @@
*
KP = IMAX
*
* copy column K+1 of W to column K
* copy column K+1 of W to column K of W
*
CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
*
* Case(4)
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
@ -573,15 +725,29 @@
KP = IMAX
KSTEP = 2
END IF
*
*
* END pivot search along IMAX row
*
END IF
*
* END pivot search
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
* Updated column KP is already stored in column KK of W
* Interchange rows and columns KP and KK.
* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
* Copy non-updated column KK to column KP of submatrix A
* at step K. No need to copy element into column K
* (or K and K+1 for 2-by-2 pivot) of A, since these columns
* will be later overwritten.
*
A( KP, KP ) = REAL( A( KK, KK ) )
CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
@ -590,9 +756,13 @@
IF( KP.LT.N )
$ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
*
* Interchange rows KK and KP in first KK columns of A and W
* Interchange rows KK and KP in first K-1 columns of A
* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
* later overwritten). Interchange rows KK and KP
* in first KK columns of W.
*
CALL CSWAP( KK-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
IF( K.GT.1 )
$ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
@ -600,21 +770,35 @@
*
* 1-by-1 pivot block D(k): column k of W now holds
*
* W(k) = L(k)*D(k)
* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
* Store L(k) in column k of A
* (1) Store subdiag. elements of column L(k)
* and 1-by-1 block D(k) in column k of A.
* (NOTE: Diagonal element L(k,k) is a UNIT element
* and not stored)
* A(k,k) := D(k,k) = W(k,k)
* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
* (NOTE: No need to use for Hermitian matrix
* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
* element D(k,k) from W (potentially saves only one load))
CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
*
* (NOTE: No need to check if A(k,k) is NOT ZERO,
* since that was ensured earlier in pivot search:
* case A(k,k) = 0 falls into 2x2 pivot case(4))
*
R1 = ONE / REAL( A( K, K ) )
CALL CSSCAL( N-K, R1, A( K+1, K ), 1 )
*
* Conjugate W(k)
* (2) Conjugate column W(k)
*
CALL CLACGV( N-K, W( K+1, K ), 1 )
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
@ -623,16 +807,69 @@
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
* block D(k:k+1,k:k+1) in columns k and k+1 of A.
* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
* block and not stored)
* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
* Store L(k) and L(k+1) in columns k and k+1 of A
* Factor out the columns of the inverse of 2-by-2 pivot
* block D, so that each column contains 1, to reduce the
* number of FLOPS when we multiply panel
* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
*
* D**(-1) = ( d11 cj(d21) )**(-1) =
* ( d21 d22 )
*
* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
* ( (-d21) ( d11 ) )
*
* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
*
* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
* ( ( -1 ) ( d11/conj(d21) ) )
*
* = 1/(|d21|**2) * 1/(D22*D11-1) *
*
* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = ( conj(D21)*( D11 ) D21*( -1 ) )
* ( ( -1 ) ( D22 ) )
*
* where D11 = d22/d21,
* D22 = d11/conj(d21),
* D21 = T/d21,
* T = 1/(D22*D11-1).
*
* (NOTE: No need to check for division by ZERO,
* since that was ensured earlier in pivot search:
* (a) d21 != 0, since in 2x2 pivot case(4)
* |d21| should be larger than |d11| and |d22|;
* (b) (D22*D11 - 1) != 0, since from (a),
* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / CONJG( D21 )
T = ONE / ( REAL( D11*D22 )-ONE )
D21 = T / D21
*
* Update elements in columns A(k) and A(k+1) as
* dot products of rows of ( W(k) W(k+1) ) and columns
* of D**(-1)
*
DO 80 J = K + 2, N
A( J, K ) = CONJG( D21 )*
$ ( D11*W( J, K )-W( J, K+1 ) )
@ -646,11 +883,13 @@
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
*
* Conjugate W(k) and W(k+1)
* (2) Conjugate columns W(k) and W(k+1)
*
CALL CLACGV( N-K, W( K+1, K ), 1 )
CALL CLACGV( N-K-1, W( K+2, K+1 ), 1 )
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
@ -698,16 +937,24 @@
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
* in columns 1:k-1
* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
*
* Undo the interchanges (if any) of rows J and JP
* at each step J
*
* (Here, J is a diagonal index)
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
* (Here, J is a diagonal index)
J = J - 1
END IF
* (NOTE: Here, J is used to determine row length. Length J
* of the rows to swap back doesn't include diagonal element)
J = J - 1
IF( JP.NE.JJ .AND. J.GE.1 )
$ CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )

1176
lapack-netlib/SRC/clahef_rook.f Normal file
View File

File diff suppressed because it is too large Load Diff

261
lapack-netlib/SRC/clarfb.f
View File

@ -159,7 +159,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date June 2013
*
*> \ingroup complexOTHERauxiliary
*
@ -195,10 +195,10 @@
SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* June 2013
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
@ -217,12 +217,11 @@
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J, LASTV, LASTC
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILACLR, ILACLC
EXTERNAL LSAME, ILACLR, ILACLC
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL CCOPY, CGEMM, CLACGV, CTRMM
@ -255,36 +254,33 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILACLR( M, K, V, LDV ) )
LASTC = ILACLC( LASTV, N, C, LDC )
*
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
*
* W := C1**H
*
DO 10 J = 1, K
CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL CLACGV( LASTC, WORK( 1, J ), 1 )
CALL CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL CLACGV( N, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**H *V2
*
CALL CGEMM( 'Conjugate transpose', 'No transpose',
$ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
CALL CGEMM( 'Conjugate transpose', 'No transpose', N,
$ K, M-K, ONE, C( K+1, 1 ), LDC,
$ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
@ -293,19 +289,19 @@
* C2 := C2 - V2 * W**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ LASTV-K, LASTC, K, -ONE, V( K+1, 1 ), LDV,
$ WORK, LDWORK, ONE, C( K+1, 1 ), LDC )
$ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK,
$ LDWORK, ONE, C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
$ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 30 J = 1, K
DO 20 I = 1, LASTC
DO 20 I = 1, N
C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
20 CONTINUE
30 CONTINUE
@ -313,58 +309,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
LASTV = MAX( K, ILACLR( N, K, V, LDV ) )
LASTC = ILACLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
CALL CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL CGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-K,
CALL CGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
IF( LASTV.GT.K ) THEN
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, LASTV-K, K,
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
$ ONE, C( 1, K+1 ), LDC )
CALL CGEMM( 'No transpose', 'Conjugate transpose', M,
$ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ),
$ LDV, ONE, C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
$ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, LASTC
DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
@ -380,37 +371,33 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
LASTC = ILACLC( M, N, C, LDC )
*
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
*
* W := C2**H
*
DO 70 J = 1, K
CALL CCOPY( LASTC, C( M-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
CALL CLACGV( LASTC, WORK( 1, J ), 1 )
CALL CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
CALL CLACGV( N, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( M-K+1, 1 ), LDV,
$ WORK, LDWORK )
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**H * V1
*
CALL CGEMM( 'Conjugate transpose', 'No transpose',
$ LASTC, K, M-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
CALL CGEMM( 'Conjugate transpose', 'No transpose', N,
$ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK,
$ LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
@ -419,20 +406,20 @@
* C1 := C1 - V1 * W**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
$ M-K, N, K, -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
END IF
*
* W := W * V2**H
*
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( M-K+1, 1 ), LDV,
$ WORK, LDWORK )
$ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK,
$ LDWORK )
*
* C2 := C2 - W**H
*
DO 90 J = 1, K
DO 80 I = 1, LASTC
DO 80 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) -
$ CONJG( WORK( I, J ) )
80 CONTINUE
@ -441,36 +428,31 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
LASTC = ILACLR( M, N, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL CCOPY( LASTC, C( 1, N-K+J ), 1,
$ WORK( 1, J ), 1 )
CALL CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( N-K+1, 1 ), LDV,
$ WORK, LDWORK )
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL CGEMM( 'No transpose', 'No transpose',
$ LASTC, K, N-K,
CALL CGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
@ -478,23 +460,22 @@
*
* C1 := C1 - W * V1**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
CALL CGEMM( 'No transpose', 'Conjugate transpose', M,
$ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE,
$ C, LDC )
END IF
*
* W := W * V2**H
*
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( N-K+1, 1 ), LDV,
$ WORK, LDWORK )
$ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK,
$ LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, LASTC
C( I, N-K+J ) = C( I, N-K+J )
$ - WORK( I, J )
DO 110 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
110 CONTINUE
120 CONTINUE
END IF
@ -511,59 +492,56 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILACLC( K, M, V, LDV ) )
LASTC = ILACLC( LASTV, N, C, LDC )
*
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
*
* W := C1**H
*
DO 130 J = 1, K
CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL CLACGV( LASTC, WORK( 1, J ), 1 )
CALL CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL CLACGV( N, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
$ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**H * V2**H
*
CALL CGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTC, K, LASTV-K,
$ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
$ ONE, WORK, LDWORK )
$ 'Conjugate transpose', N, K, M-K, ONE,
$ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
$ WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
IF( LASTV.GT.K ) THEN
IF( M.GT.K ) THEN
*
* C2 := C2 - V2**H * W**H
*
CALL CGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTV-K, LASTC, K,
$ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
$ ONE, C( K+1, 1 ), LDC )
$ 'Conjugate transpose', M-K, N, K, -ONE,
$ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 150 J = 1, K
DO 140 I = 1, LASTC
DO 140 I = 1, N
C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
140 CONTINUE
150 CONTINUE
@ -571,57 +549,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
LASTV = MAX( K, ILACLC( K, N, V, LDV ) )
LASTC = ILACLR( M, LASTV, C, LDC )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
CALL CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
$ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
CALL CGEMM( 'No transpose', 'Conjugate transpose', M,
$ K, N-K, ONE, C( 1, K+1 ), LDC,
$ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL CGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
$ ONE, C( 1, K+1 ), LDC )
CALL CGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, LASTC
DO 170 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
@ -637,37 +611,34 @@
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
LASTC = ILACLC( M, N, C, LDC )
*
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
*
* W := C2**H
*
DO 190 J = 1, K
CALL CCOPY( LASTC, C( M-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
CALL CLACGV( LASTC, WORK( 1, J ), 1 )
CALL CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
CALL CLACGV( N, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( 1, M-K+1 ), LDV,
$ WORK, LDWORK )
$ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK,
$ LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**H * V1**H
*
CALL CGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTC, K, M-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
$ 'Conjugate transpose', N, K, M-K, ONE, C,
$ LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
@ -676,20 +647,19 @@
* C1 := C1 - V1**H * W**H
*
CALL CGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', M-K, LASTC, K,
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
$ 'Conjugate transpose', M-K, N, K, -ONE, V,
$ LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, M-K+1 ), LDV,
$ WORK, LDWORK )
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**H
*
DO 210 J = 1, K
DO 200 I = 1, LASTC
DO 200 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) -
$ CONJG( WORK( I, J ) )
200 CONTINUE
@ -698,36 +668,33 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
LASTC = ILACLR( M, N, C, LDC )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL CCOPY( LASTC, C( 1, N-K+J ), 1,
$ WORK( 1, J ), 1 )
CALL CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( 1, N-K+1 ), LDV,
$ WORK, LDWORK )
$ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK,
$ LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, K, N-K, ONE, C, LDC, V, LDV, ONE,
$ WORK, LDWORK )
CALL CGEMM( 'No transpose', 'Conjugate transpose', M,
$ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK,
$ LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
@ -735,21 +702,19 @@
*
* C1 := C1 - W * V1
*
CALL CGEMM( 'No transpose', 'No transpose',
$ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
CALL CGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, N-K+1 ), LDV,
$ WORK, LDWORK )
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, LASTC
DO 230 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
230 CONTINUE
240 CONTINUE

20
lapack-netlib/SRC/clartg.f
View File

@ -85,7 +85,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup complexOTHERauxiliary
*
@ -103,10 +103,10 @@
* =====================================================================
SUBROUTINE CLARTG( F, G, CS, SN, R )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
REAL CS
@ -130,7 +130,8 @@
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2
EXTERNAL SLAMCH, SLAPY2
LOGICAL SISNAN
EXTERNAL SLAMCH, SLAPY2, SISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, LOG, MAX, REAL,
@ -139,26 +140,17 @@
* .. Statement Functions ..
REAL ABS1, ABSSQ
* ..
* .. Save statement ..
* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
* ..
* .. Data statements ..
* DATA FIRST / .TRUE. /
* ..
* .. Statement Function definitions ..
ABS1( FF ) = MAX( ABS( REAL( FF ) ), ABS( AIMAG( FF ) ) )
ABSSQ( FF ) = REAL( FF )**2 + AIMAG( FF )**2
* ..
* .. Executable Statements ..
*
* IF( FIRST ) THEN
SAFMIN = SLAMCH( 'S' )
EPS = SLAMCH( 'E' )
SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( SLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
* FIRST = .FALSE.
* END IF
SCALE = MAX( ABS1( F ), ABS1( G ) )
FS = F
GS = G
@ -172,7 +164,7 @@
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
ELSE IF( SCALE.LE.SAFMN2 ) THEN
IF( G.EQ.CZERO ) THEN
IF( G.EQ.CZERO.OR.SISNAN( ABS( G ) ) ) THEN
CS = ONE
SN = CZERO
R = F

246
lapack-netlib/SRC/clasyf.f
View File

@ -1,4 +1,4 @@
*> \brief \b CLASYF computes a partial factorization of a complex symmetric matrix, using the diagonal pivoting method.
*> \brief \b CLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
*
* =========== DOCUMENTATION ===========
*
@ -110,16 +110,26 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*> If UPLO = 'U', only the last KB elements of IPIV are set;
*> if UPLO = 'L', only the first KB elements are set.
*>
*> If UPLO = 'U':
*> Only the last KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*>
*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> Only the first KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
@ -150,17 +160,27 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup complexSYcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*> \endverbatim
*
* =====================================================================
SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@ -246,7 +266,8 @@
ABSAKK = CABS1( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, W( 1, KW ), 1 )
@ -257,7 +278,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@ -302,7 +323,7 @@
*
KP = IMAX
*
* copy column KW-1 of W to column KW
* copy column KW-1 of W to column KW of W
*
CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
ELSE
@ -314,59 +335,117 @@
KSTEP = 2
END IF
END IF
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
*
* KKW is the column of W which corresponds to column KK of A
*
KKW = NB + KK - N
*
* Updated column KP is already stored in column KKW of W
* Interchange rows and columns KP and KK.
* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
* Copy non-updated column KK to column KP of submatrix A
* at step K. No need to copy element into column K
* (or K and K-1 for 2-by-2 pivot) of A, since these columns
* will be later overwritten.
*
A( KP, K ) = A( KK, K )
CALL CCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
A( KP, KP ) = A( KK, KK )
CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL CCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
IF( KP.GT.1 )
$ CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
* Interchange rows KK and KP in last KK columns of A and W
* Interchange rows KK and KP in last K+1 to N columns of A
* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
* later overwritten). Interchange rows KK and KP
* in last KKW to NB columns of W.
*
CALL CSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
IF( K.LT.N )
$ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
$ LDA )
CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column KW of W now holds
* 1-by-1 pivot block D(k): column kw of W now holds
*
* W(k) = U(k)*D(k)
* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
* Store U(k) in column k of A
* Store subdiag. elements of column U(k)
* and 1-by-1 block D(k) in column k of A.
* NOTE: Diagonal element U(k,k) is a UNIT element
* and not stored.
* A(k,k) := D(k,k) = W(k,kw)
* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
R1 = CONE / A( K, K )
CALL CSCAL( K-1, R1, A( 1, K ), 1 )
*
ELSE
*
* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
* hold
* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
* block D(k-1:k,k-1:k) in columns k-1 and k of A.
* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
* block and not stored.
* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
* Store U(k) and U(k-1) in columns k and k-1 of A
* Compose the columns of the inverse of 2-by-2 pivot
* block D in the following way to reduce the number
* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by
* this inverse
*
* D**(-1) = ( d11 d21 )**(-1) =
* ( d21 d22 )
*
* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
* ( (-d21 ) ( d11 ) )
*
* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
*
* * ( ( d22/d21 ) ( -1 ) ) =
* ( ( -1 ) ( d11/d21 ) )
*
* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = 1/d21 * T * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
* = D21 * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / D21
D22 = W( K-1, KW-1 ) / D21
T = CONE / ( D11*D22-CONE )
*
* Update elements in columns A(k-1) and A(k) as
* dot products of rows of ( W(kw-1) W(kw) ) and columns
* of D**(-1)
*
D21 = T / D21
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
@ -379,7 +458,9 @@
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
@ -423,20 +504,28 @@
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
* in columns k+1:n
* in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
*
* Undo the interchanges (if any) of rows JJ and JP at each
* step J
*
* (Here, J is a diagonal index)
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
* (Here, J is a diagonal index)
J = J + 1
END IF
* (NOTE: Here, J is used to determine row length. Length N-J+1
* of the rows to swap back doesn't include diagonal element)
J = J + 1
IF( JP.NE.JJ .AND. J.LE.N )
$ CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
IF( J.LE.N )
IF( J.LT.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
@ -473,7 +562,8 @@
ABSAKK = CABS1( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 )
@ -484,7 +574,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@ -528,7 +618,7 @@
*
KP = IMAX
*
* copy column K+1 of W to column K
* copy column K+1 of W to column K of W
*
CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
ELSE
@ -540,22 +630,36 @@
KSTEP = 2
END IF
END IF
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
* Updated column KP is already stored in column KK of W
* Interchange rows and columns KP and KK.
* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
* Copy non-updated column KK to column KP of submatrix A
* at step K. No need to copy element into column K
* (or K and K+1 for 2-by-2 pivot) of A, since these columns
* will be later overwritten.
*
A( KP, K ) = A( KK, K )
CALL CCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
CALL CCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
A( KP, KP ) = A( KK, KK )
CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
$ LDA )
IF( KP.LT.N )
$ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
*
* Interchange rows KK and KP in first KK columns of A and W
* Interchange rows KK and KP in first K-1 columns of A
* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
* later overwritten). Interchange rows KK and KP
* in first KK columns of W.
*
CALL CSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
IF( K.GT.1 )
$ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
@ -563,17 +667,23 @@
*
* 1-by-1 pivot block D(k): column k of W now holds
*
* W(k) = L(k)*D(k)
* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
* Store L(k) in column k of A
* Store subdiag. elements of column L(k)
* and 1-by-1 block D(k) in column k of A.
* (NOTE: Diagonal element L(k,k) is a UNIT element
* and not stored)
* A(k,k) := D(k,k) = W(k,k)
* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
R1 = CONE / A( K, K )
CALL CSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
@ -582,16 +692,52 @@
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
* block D(k:k+1,k:k+1) in columns k and k+1 of A.
* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
* block and not stored)
* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
* Store L(k) and L(k+1) in columns k and k+1 of A
* Compose the columns of the inverse of 2-by-2 pivot
* block D in the following way to reduce the number
* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by
* this inverse
*
* D**(-1) = ( d11 d21 )**(-1) =
* ( d21 d22 )
*
* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
* ( (-d21 ) ( d11 ) )
*
* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
*
* * ( ( d22/d21 ) ( -1 ) ) =
* ( ( -1 ) ( d11/d21 ) )
*
* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = 1/d21 * T * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
* = D21 * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = CONE / ( D11*D22-CONE )
D21 = T / D21
*
* Update elements in columns A(k) and A(k+1) as
* dot products of rows of ( W(k) W(k+1) ) and columns
* of D**(-1)
*
DO 80 J = K + 2, N
A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
@ -603,7 +749,9 @@
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
@ -648,20 +796,28 @@
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
* in columns 1:k-1
* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
*
* Undo the interchanges (if any) of rows JJ and JP at each
* step J
*
* (Here, J is a diagonal index)
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
* (Here, J is a diagonal index)
J = J - 1
END IF
* (NOTE: Here, J is used to determine row length. Length J
* of the rows to swap back doesn't include diagonal element)
J = J - 1
IF( JP.NE.JJ .AND. J.GE.1 )
$ CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
IF( J.GE.1 )
IF( J.GT.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized

900
lapack-netlib/SRC/clasyf_rook.f Normal file
View File

@ -0,0 +1,900 @@
*> \brief \b CLASYF_ROOK computes a partial factorization of a complex symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLASYF_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clasyf_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clasyf_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clasyf_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), W( LDW, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLASYF_ROOK computes a partial factorization of a complex symmetric
*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal
*> pivoting method. The partial factorization has the form:
*>
*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
*>
*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
*> ( L21 I ) ( 0 A22 ) ( 0 I )
*>
*> where the order of D is at most NB. The actual order is returned in
*> the argument KB, and is either NB or NB-1, or N if N <= NB.
*>
*> CLASYF_ROOK is an auxiliary routine called by CSYTRF_ROOK. It uses
*> blocked code (calling Level 3 BLAS) to update the submatrix
*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> The maximum number of columns of the matrix A that should be
*> factored. NB should be at least 2 to allow for 2-by-2 pivot
*> blocks.
*> \endverbatim
*>
*> \param[out] KB
*> \verbatim
*> KB is INTEGER
*> The number of columns of A that were actually factored.
*> KB is either NB-1 or NB, or N if N <= NB.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit, A contains details of the partial factorization.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> Only the last KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> Only the first KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX array, dimension (LDW,NB)
*> \endverbatim
*>
*> \param[in] LDW
*> \verbatim
*> LDW is INTEGER
*> The leading dimension of the array W. LDW >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complexSYcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW,
$ INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), W( LDW, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
COMPLEX CONE, CZERO
PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ),
$ CZERO = ( 0.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK,
$ KW, KKW, KP, KSTEP, P, II
REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN
COMPLEX D11, D12, D21, D22, R1, T, Z
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ICAMAX
REAL SLAMCH
EXTERNAL LSAME, ICAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL CCOPY, CGEMM, CGEMV, CSCAL, CSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT, AIMAG, REAL
* ..
* .. Statement Functions ..
REAL CABS1
* ..
* .. Statement Function definitions ..
CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
* Compute machine safe minimum
*
SFMIN = SLAMCH( 'S' )
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Factorize the trailing columns of A using the upper triangle
* of A and working backwards, and compute the matrix W = U12*D
* for use in updating A11
*
* K is the main loop index, decreasing from N in steps of 1 or 2
*
K = N
10 CONTINUE
*
* KW is the column of W which corresponds to column K of A
*
KW = NB + K - N
*
* Exit from loop
*
IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
$ GO TO 30
*
KSTEP = 1
P = K
*
* Copy column K of A to column KW of W and update it
*
CALL CCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
IF( K.LT.N )
$ CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ),
$ LDA, W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = CABS1( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, W( 1, KW ), 1 )
COLMAX = CABS1( W( IMAX, KW ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
ELSE
*
* ============================================================
*
* Test for interchange
*
* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
* (used to handle NaN and Inf)
*
IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
ELSE
*
DONE = .FALSE.
*
* Loop until pivot found
*
12 CONTINUE
*
* Begin pivot search loop body
*
*
* Copy column IMAX to column KW-1 of W and update it
*
CALL CCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
$ W( IMAX+1, KW-1 ), 1 )
*
IF( K.LT.N )
$ CALL CGEMV( 'No transpose', K, N-K, -CONE,
$ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
$ CONE, W( 1, KW-1 ), 1 )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine both ROWMAX and JMAX.
*
IF( IMAX.NE.K ) THEN
JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ),
$ 1 )
ROWMAX = CABS1( W( JMAX, KW-1 ) )
ELSE
ROWMAX = ZERO
END IF
*
IF( IMAX.GT.1 ) THEN
ITEMP = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 )
STEMP = CABS1( W( ITEMP, KW-1 ) )
IF( STEMP.GT.ROWMAX ) THEN
ROWMAX = STEMP
JMAX = ITEMP
END IF
END IF
*
* Equivalent to testing for
* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
* (used to handle NaN and Inf)
*
IF( .NOT.(CABS1( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) )
$ THEN
*
* interchange rows and columns K and IMAX,
* use 1-by-1 pivot block
*
KP = IMAX
*
* copy column KW-1 of W to column KW of W
*
CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
*
DONE = .TRUE.
*
* Equivalent to testing for ROWMAX.EQ.COLMAX,
* (used to handle NaN and Inf)
*
ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
$ THEN
*
* interchange rows and columns K-1 and IMAX,
* use 2-by-2 pivot block
*
KP = IMAX
KSTEP = 2
DONE = .TRUE.
ELSE
*
* Pivot not found: set params and repeat
*
P = IMAX
COLMAX = ROWMAX
IMAX = JMAX
*
* Copy updated JMAXth (next IMAXth) column to Kth of W
*
CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
*
END IF
*
* End pivot search loop body
*
IF( .NOT. DONE ) GOTO 12
*
END IF
*
* ============================================================
*
KK = K - KSTEP + 1
*
* KKW is the column of W which corresponds to column KK of A
*
KKW = NB + KK - N
*
IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
*
* Copy non-updated column K to column P
*
CALL CCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA )
CALL CCOPY( P, A( 1, K ), 1, A( 1, P ), 1 )
*
* Interchange rows K and P in last N-K+1 columns of A
* and last N-K+2 columns of W
*
CALL CSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA )
CALL CSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW )
END IF
*
* Updated column KP is already stored in column KKW of W
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
*
A( KP, K ) = A( KK, K )
CALL CCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL CCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
*
* Interchange rows KK and KP in last N-KK+1 columns
* of A and W
*
CALL CSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column KW of W now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Store U(k) in column k of A
*
CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
IF( K.GT.1 ) THEN
IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
R1 = CONE / A( K, K )
CALL CSCAL( K-1, R1, A( 1, K ), 1 )
ELSE IF( A( K, K ).NE.CZERO ) THEN
DO 14 II = 1, K - 1
A( II, K ) = A( II, K ) / A( K, K )
14 CONTINUE
END IF
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
* hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
IF( K.GT.2 ) THEN
*
* Store U(k) and U(k-1) in columns k and k-1 of A
*
D12 = W( K-1, KW )
D11 = W( K, KW ) / D12
D22 = W( K-1, KW-1 ) / D12
T = CONE / ( D11*D22-CONE )
DO 20 J = 1, K - 2
A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) /
$ D12 )
A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
$ D12 )
20 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -P
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
30 CONTINUE
*
* Update the upper triangle of A11 (= A(1:k,1:k)) as
*
* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
*
* computing blocks of NB columns at a time
*
DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
JB = MIN( NB, K-J+1 )
*
* Update the upper triangle of the diagonal block
*
DO 40 JJ = J, J + JB - 1
CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
$ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
$ A( J, JJ ), 1 )
40 CONTINUE
*
* Update the rectangular superdiagonal block
*
IF( J.GE.2 )
$ CALL CGEMM( 'No transpose', 'Transpose', J-1, JB,
$ N-K, -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
$ CONE, A( 1, J ), LDA )
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
* in columns k+1:n
*
J = K + 1
60 CONTINUE
*
KSTEP = 1
JP1 = 1
JJ = J
JP2 = IPIV( J )
IF( JP2.LT.0 ) THEN
JP2 = -JP2
J = J + 1
JP1 = -IPIV( J )
KSTEP = 2
END IF
*
J = J + 1
IF( JP2.NE.JJ .AND. J.LE.N )
$ CALL CSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA )
JJ = J - 1
IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
$ CALL CSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA )
IF( J.LE.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
*
KB = N - K
*
ELSE
*
* Factorize the leading columns of A using the lower triangle
* of A and working forwards, and compute the matrix W = L21*D
* for use in updating A22
*
* K is the main loop index, increasing from 1 in steps of 1 or 2
*
K = 1
70 CONTINUE
*
* Exit from loop
*
IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
$ GO TO 90
*
KSTEP = 1
P = K
*
* Copy column K of A to column K of W and update it
*
CALL CCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
IF( K.GT.1 )
$ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
$ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 )
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = CABS1( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 )
COLMAX = CABS1( W( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
ELSE
*
* ============================================================
*
* Test for interchange
*
* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
* (used to handle NaN and Inf)
*
IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
ELSE
*
DONE = .FALSE.
*
* Loop until pivot found
*
72 CONTINUE
*
* Begin pivot search loop body
*
*
* Copy column IMAX to column K+1 of W and update it
*
CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
CALL CCOPY( N-IMAX+1, A( IMAX, IMAX ), 1,
$ W( IMAX, K+1 ), 1 )
IF( K.GT.1 )
$ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE,
$ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
$ CONE, W( K, K+1 ), 1 )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine both ROWMAX and JMAX.
*
IF( IMAX.NE.K ) THEN
JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 )
ROWMAX = CABS1( W( JMAX, K+1 ) )
ELSE
ROWMAX = ZERO
END IF
*
IF( IMAX.LT.N ) THEN
ITEMP = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
STEMP = CABS1( W( ITEMP, K+1 ) )
IF( STEMP.GT.ROWMAX ) THEN
ROWMAX = STEMP
JMAX = ITEMP
END IF
END IF
*
* Equivalent to testing for
* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
* (used to handle NaN and Inf)
*
IF( .NOT.( CABS1( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) )
$ THEN
*
* interchange rows and columns K and IMAX,
* use 1-by-1 pivot block
*
KP = IMAX
*
* copy column K+1 of W to column K of W
*
CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
*
DONE = .TRUE.
*
* Equivalent to testing for ROWMAX.EQ.COLMAX,
* (used to handle NaN and Inf)
*
ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
$ THEN
*
* interchange rows and columns K+1 and IMAX,
* use 2-by-2 pivot block
*
KP = IMAX
KSTEP = 2
DONE = .TRUE.
ELSE
*
* Pivot not found: set params and repeat
*
P = IMAX
COLMAX = ROWMAX
IMAX = JMAX
*
* Copy updated JMAXth (next IMAXth) column to Kth of W
*
CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
*
END IF
*
* End pivot search loop body
*
IF( .NOT. DONE ) GOTO 72
*
END IF
*
* ============================================================
*
KK = K + KSTEP - 1
*
IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
*
* Copy non-updated column K to column P
*
CALL CCOPY( P-K, A( K, K ), 1, A( P, K ), LDA )
CALL CCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 )
*
* Interchange rows K and P in first K columns of A
* and first K+1 columns of W
*
CALL CSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA )
CALL CSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
END IF
*
* Updated column KP is already stored in column KK of W
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
*
A( KP, K ) = A( KK, K )
CALL CCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
CALL CCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
*
* Interchange rows KK and KP in first KK columns of A and W
*
CALL CSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k of W now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
* Store L(k) in column k of A
*
CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
R1 = CONE / A( K, K )
CALL CSCAL( N-K, R1, A( K+1, K ), 1 )
ELSE IF( A( K, K ).NE.CZERO ) THEN
DO 74 II = K + 1, N
A( II, K ) = A( II, K ) / A( K, K )
74 CONTINUE
END IF
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
IF( K.LT.N-1 ) THEN
*
* Store L(k) and L(k+1) in columns k and k+1 of A
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = CONE / ( D11*D22-CONE )
DO 80 J = K + 2, N
A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
$ D21 )
A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
$ D21 )
80 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -P
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 70
*
90 CONTINUE
*
* Update the lower triangle of A22 (= A(k:n,k:n)) as
*
* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
*
* computing blocks of NB columns at a time
*
DO 110 J = K, N, NB
JB = MIN( NB, N-J+1 )
*
* Update the lower triangle of the diagonal block
*
DO 100 JJ = J, J + JB - 1
CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
$ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
$ A( JJ, JJ ), 1 )
100 CONTINUE
*
* Update the rectangular subdiagonal block
*
IF( J+JB.LE.N )
$ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
$ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
$ CONE, A( J+JB, J ), LDA )
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
* in columns 1:k-1
*
J = K - 1
120 CONTINUE
*
KSTEP = 1
JP1 = 1
JJ = J
JP2 = IPIV( J )
IF( JP2.LT.0 ) THEN
JP2 = -JP2
J = J - 1
JP1 = -IPIV( J )
KSTEP = 2
END IF
*
J = J - 1
IF( JP2.NE.JJ .AND. J.GE.1 )
$ CALL CSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA )
JJ = J + 1
IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
$ CALL CSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA )
IF( J.GE.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
*
KB = K - 1
*
END IF
RETURN
*
* End of CLASYF_ROOK
*
END

7
lapack-netlib/SRC/cstemr.f
View File

@ -311,7 +311,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@ -329,10 +329,10 @@
$ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
@ -408,6 +408,7 @@
WU = ZERO
IIL = 0
IIU = 0
NSPLIT = 0
IF( VALEIG ) THEN
* We do not reference VL, VU in the cases RANGE = 'I','A'

255
lapack-netlib/SRC/csycon_rook.f Normal file
View File

@ -0,0 +1,255 @@
*> \brief \b CSYCON_ROOK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CSYCON_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csycon_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csycon_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csycon_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND,
* WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* REAL ANORM, RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSYCON_ROOK estimates the reciprocal of the condition number (in the
*> 1-norm) of a complex symmetric matrix A using the factorization
*> A = U*D*U**T or A = L*D*L**T computed by CSYTRF_ROOK.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by CSYTRF_ROOK.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by CSYTRF_ROOK.
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*> ANORM is REAL
*> The 1-norm of the original matrix A.
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*> RCOND is REAL
*> The reciprocal of the condition number of the matrix A,
*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
*> estimate of the 1-norm of inv(A) computed in this routine.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complexSYcomputational
*
*> \par Contributors:
* ==================
*> \verbatim
*>
*> April 2012, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE CSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
COMPLEX CZERO
PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, KASE
REAL AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL CLACN2, CSYTRS_ROOK, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CSYCON_ROOK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO )
$ RETURN
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
*
CALL CSYTRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of CSYCON_ROOK
*
END

293
lapack-netlib/SRC/csysv_rook.f Normal file
View File

@ -0,0 +1,293 @@
*> \brief <b> CSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CSYSV_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csysv_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csysv_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csysv_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
* LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSYSV_ROOK computes the solution to a complex system of linear
*> equations
*> A * X = B,
*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
*> matrices.
*>
*> The diagonal pivoting method is used to factor A as
*> A = U * D * U**T, if UPLO = 'U', or
*> A = L * D * L**T, if UPLO = 'L',
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is symmetric and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.
*>
*> CSYTRF_ROOK is called to compute the factorization of a complex
*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
*> pivoting method.
*>
*> The factored form of A is then used to solve the system
*> of equations A * X = B by calling CSYTRS_ROOK.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of linear equations, i.e., the order of the
*> matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the block diagonal matrix D and the
*> multipliers used to obtain the factor U or L from the
*> factorization A = U*D*U**T or A = L*D*L**T as computed by
*> CSYTRF_ROOK.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D,
*> as determined by CSYTRF_ROOK.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS right hand side matrix B.
*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of WORK. LWORK >= 1, and for best performance
*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for
*> CSYTRF_ROOK.
*>
*> TRS will be done with Level 2 BLAS
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular, so the solution could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complexSYsolve
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> April 2012, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE CSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
$ LWORK, INFO )
*
* -- LAPACK driver routine (version 3.4.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, LWORK, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LWKOPT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, CSYTRF_ROOK, CSYTRS_ROOK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
LWKOPT = 1
ELSE
CALL CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO )
LWKOPT = WORK(1)
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CSYSV_ROOK ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Compute the factorization A = U*D*U**T or A = L*D*L**T.
*
CALL CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
* Solve with TRS_ROOK ( Use Level 2 BLAS)
*
CALL CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
END IF
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of CSYSV_ROOK
*
END

37
lapack-netlib/SRC/csytf2.f
View File

@ -90,13 +90,22 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*>
*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
@ -118,7 +127,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup complexSYcomputational
*
@ -182,10 +191,10 @@
* =====================================================================
SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@ -273,7 +282,8 @@
ABSAKK = CABS1( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, A( 1, K ), 1 )
@ -284,7 +294,8 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. SISNAN(ABSAKK) ) THEN
*
* Column K is zero or NaN: set INFO and continue
* Column K is zero or underflow, or contains a NaN:
* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@ -441,7 +452,8 @@
ABSAKK = CABS1( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 )
@ -452,7 +464,8 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. SISNAN(ABSAKK) ) THEN
*
* Column K is zero or NaN: set INFO and continue
* Column K is zero or underflow, or contains a NaN:
* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K

821
lapack-netlib/SRC/csytf2_rook.f Normal file
View File

@ -0,0 +1,821 @@
*> \brief \b CSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CSYTF2_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csytf2_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csytf2_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csytf2_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSYTF2_ROOK computes the factorization of a complex symmetric matrix A
*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
*>
*> A = U*D*U**T or A = L*D*L**T
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, U**T is the transpose of U, and D is symmetric and
*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
*>
*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L (see below for further details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the k-th argument had an illegal value
*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular, and division by zero will occur if it
*> is used to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complexSYcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**T, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**T, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> 01-01-96 - Based on modifications by
*> J. Lewis, Boeing Computer Services Company
*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA
*> \endverbatim
*
* =====================================================================
SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
COMPLEX CONE
PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER, DONE
INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
$ P, II
REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN
COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ICAMAX
REAL SLAMCH
EXTERNAL LSAME, ICAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL CSCAL, CSWAP, CSYR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT, AIMAG, REAL
* ..
* .. Statement Functions ..
REAL CABS1
* ..
* .. Statement Function definitions ..
CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CSYTF2_ROOK', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
* Compute machine safe minimum
*
SFMIN = SLAMCH( 'S' )
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**T using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 70
KSTEP = 1
P = K
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = CABS1( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = ICAMAX( K-1, A( 1, K ), 1 )
COLMAX = CABS1( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
*
* Test for interchange
*
* Equivalent to testing for (used to handle NaN and Inf)
* ABSAKK.GE.ALPHA*COLMAX
*
IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
*
* no interchange,
* use 1-by-1 pivot block
*
KP = K
ELSE
*
DONE = .FALSE.
*
* Loop until pivot found
*
12 CONTINUE
*
* Begin pivot search loop body
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine both ROWMAX and JMAX.
*
IF( IMAX.NE.K ) THEN
JMAX = IMAX + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ),
$ LDA )
ROWMAX = CABS1( A( IMAX, JMAX ) )
ELSE
ROWMAX = ZERO
END IF
*
IF( IMAX.GT.1 ) THEN
ITEMP = ICAMAX( IMAX-1, A( 1, IMAX ), 1 )
STEMP = CABS1( A( ITEMP, IMAX ) )
IF( STEMP.GT.ROWMAX ) THEN
ROWMAX = STEMP
JMAX = ITEMP
END IF
END IF
*
* Equivalent to testing for (used to handle NaN and Inf)
* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
*
IF( .NOT.( CABS1(A( IMAX, IMAX )).LT.ALPHA*ROWMAX ) )
$ THEN
*
* interchange rows and columns K and IMAX,
* use 1-by-1 pivot block
*
KP = IMAX
DONE = .TRUE.
*
* Equivalent to testing for ROWMAX .EQ. COLMAX,
* used to handle NaN and Inf
*
ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
*
* interchange rows and columns K+1 and IMAX,
* use 2-by-2 pivot block
*
KP = IMAX
KSTEP = 2
DONE = .TRUE.
ELSE
*
* Pivot NOT found, set variables and repeat
*
P = IMAX
COLMAX = ROWMAX
IMAX = JMAX
END IF
*
* End pivot search loop body
*
IF( .NOT. DONE ) GOTO 12
*
END IF
*
* Swap TWO rows and TWO columns
*
* First swap
*
IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
*
* Interchange rows and column K and P in the leading
* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
*
IF( P.GT.1 )
$ CALL CSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
IF( P.LT.(K-1) )
$ CALL CSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ),
$ LDA )
T = A( K, K )
A( K, K ) = A( P, P )
A( P, P ) = T
END IF
*
* Second swap
*
KK = K - KSTEP + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the leading
* submatrix A(1:k,1:k)
*
IF( KP.GT.1 )
$ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) )
$ CALL CSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K-1, K )
A( K-1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
IF( K.GT.1 ) THEN
*
* Perform a rank-1 update of A(1:k-1,1:k-1) and
* store U(k) in column k
*
IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
* A := A - U(k)*D(k)*U(k)**T
* = A - W(k)*1/D(k)*W(k)**T
*
D11 = CONE / A( K, K )
CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
*
* Store U(k) in column k
*
CALL CSCAL( K-1, D11, A( 1, K ), 1 )
ELSE
*
* Store L(k) in column K
*
D11 = A( K, K )
DO 16 II = 1, K - 1
A( II, K ) = A( II, K ) / D11
16 CONTINUE
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
* A := A - U(k)*D(k)*U(k)**T
* = A - W(k)*(1/D(k))*W(k)**T
* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
*
CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
END IF
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
*
* and store L(k) and L(k+1) in columns k and k+1
*
IF( K.GT.2 ) THEN
*
D12 = A( K-1, K )
D22 = A( K-1, K-1 ) / D12
D11 = A( K, K ) / D12
T = CONE / ( D11*D22-CONE )
*
DO 30 J = K - 2, 1, -1
*
WKM1 = T*( D11*A( J, K-1 )-A( J, K ) )
WK = T*( D22*A( J, K )-A( J, K-1 ) )
*
DO 20 I = J, 1, -1
A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK -
$ ( A( I, K-1 ) / D12 )*WKM1
20 CONTINUE
*
* Store U(k) and U(k-1) in cols k and k-1 for row J
*
A( J, K ) = WK / D12
A( J, K-1 ) = WKM1 / D12
*
30 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -P
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**T using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 70
KSTEP = 1
P = K
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = CABS1( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 )
COLMAX = CABS1( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
*
* Test for interchange
*
* Equivalent to testing for (used to handle NaN and Inf)
* ABSAKK.GE.ALPHA*COLMAX
*
IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
DONE = .FALSE.
*
* Loop until pivot found
*
42 CONTINUE
*
* Begin pivot search loop body
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine both ROWMAX and JMAX.
*
IF( IMAX.NE.K ) THEN
JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA )
ROWMAX = CABS1( A( IMAX, JMAX ) )
ELSE
ROWMAX = ZERO
END IF
*
IF( IMAX.LT.N ) THEN
ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ),
$ 1 )
STEMP = CABS1( A( ITEMP, IMAX ) )
IF( STEMP.GT.ROWMAX ) THEN
ROWMAX = STEMP
JMAX = ITEMP
END IF
END IF
*
* Equivalent to testing for (used to handle NaN and Inf)
* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
*
IF( .NOT.( CABS1(A( IMAX, IMAX )).LT.ALPHA*ROWMAX ) )
$ THEN
*
* interchange rows and columns K and IMAX,
* use 1-by-1 pivot block
*
KP = IMAX
DONE = .TRUE.
*
* Equivalent to testing for ROWMAX .EQ. COLMAX,
* used to handle NaN and Inf
*
ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
*
* interchange rows and columns K+1 and IMAX,
* use 2-by-2 pivot block
*
KP = IMAX
KSTEP = 2
DONE = .TRUE.
ELSE
*
* Pivot NOT found, set variables and repeat
*
P = IMAX
COLMAX = ROWMAX
IMAX = JMAX
END IF
*
* End pivot search loop body
*
IF( .NOT. DONE ) GOTO 42
*
END IF
*
* Swap TWO rows and TWO columns
*
* First swap
*
IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
*
* Interchange rows and column K and P in the trailing
* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
*
IF( P.LT.N )
$ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
IF( P.GT.(K+1) )
$ CALL CSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
T = A( K, K )
A( K, K ) = A( P, P )
A( P, P ) = T
END IF
*
* Second swap
*
KK = K + KSTEP - 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the trailing
* submatrix A(k:n,k:n)
*
IF( KP.LT.N )
$ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) )
$ CALL CSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K+1, K )
A( K+1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) and
* store L(k) in column k
*
IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
* A := A - L(k)*D(k)*L(k)**T
* = A - W(k)*(1/D(k))*W(k)**T
*
D11 = CONE / A( K, K )
CALL CSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
*
* Store L(k) in column k
*
CALL CSCAL( N-K, D11, A( K+1, K ), 1 )
ELSE
*
* Store L(k) in column k
*
D11 = A( K, K )
DO 46 II = K + 1, N
A( II, K ) = A( II, K ) / D11
46 CONTINUE
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
* A := A - L(k)*D(k)*L(k)**T
* = A - W(k)*(1/D(k))*W(k)**T
* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
*
CALL CSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
END IF
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
*
* and store L(k) and L(k+1) in columns k and k+1
*
IF( K.LT.N-1 ) THEN
*
D21 = A( K+1, K )
D11 = A( K+1, K+1 ) / D21
D22 = A( K, K ) / D21
T = CONE / ( D11*D22-CONE )
*
DO 60 J = K + 2, N
*
* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
*
WK = T*( D11*A( J, K )-A( J, K+1 ) )
WKP1 = T*( D22*A( J, K+1 )-A( J, K ) )
*
* Perform a rank-2 update of A(k+2:n,k+2:n)
*
DO 50 I = J, N
A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK -
$ ( A( I, K+1 ) / D21 )*WKP1
50 CONTINUE
*
* Store L(k) and L(k+1) in cols k and k+1 for row J
*
A( J, K ) = WK / D21
A( J, K+1 ) = WKP1 / D21
*
60 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -P
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 40
*
END IF
*
70 CONTINUE
*
RETURN
*
* End of CSYTF2_ROOK
*
END

393
lapack-netlib/SRC/csytrf_rook.f Normal file
View File

@ -0,0 +1,393 @@
*> \brief \b CSYTRF_ROOK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CSYTRF_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csytrf_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csytrf_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csytrf_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSYTRF_ROOK computes the factorization of a complex symmetric matrix A
*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
*> The form of the factorization is
*>
*> A = U*D*U**T or A = L*D*L**T
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is symmetric and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.
*>
*> This is the blocked version of the algorithm, calling Level 3 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L (see below for further details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (MAX(1,LWORK)).
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of WORK. LWORK >=1. For best performance
*> LWORK >= N*NB, where NB is the block size returned by ILAENV.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular, and division by zero will occur if it
*> is used to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexSYcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**T, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**T, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2011, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL CLASYF_ROOK, CSYTF2_ROOK, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size
*
NB = ILAENV( 1, 'CSYTRF_ROOK', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CSYTRF_ROOK', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = MAX( 2, ILAENV( 2, 'CSYTRF_ROOK',
$ UPLO, N, -1, -1, -1 ) )
END IF
ELSE
IWS = 1
END IF
IF( NB.LT.NBMIN )
$ NB = N
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**T using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* KB, where KB is the number of columns factorized by CLASYF_ROOK;
* KB is either NB or NB-1, or K for the last block
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 40
*
IF( K.GT.NB ) THEN
*
* Factorize columns k-kb+1:k of A and use blocked code to
* update columns 1:k-kb
*
CALL CLASYF_ROOK( UPLO, K, NB, KB, A, LDA,
$ IPIV, WORK, LDWORK, IINFO )
ELSE
*
* Use unblocked code to factorize columns 1:k of A
*
CALL CSYTF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO )
KB = K
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* No need to adjust IPIV
*
* Decrease K and return to the start of the main loop
*
K = K - KB
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**T using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* KB, where KB is the number of columns factorized by CLASYF_ROOK;
* KB is either NB or NB-1, or N-K+1 for the last block
*
K = 1
20 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 40
*
IF( K.LE.N-NB ) THEN
*
* Factorize columns k:k+kb-1 of A and use blocked code to
* update columns k+kb:n
*
CALL CLASYF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
$ IPIV( K ), WORK, LDWORK, IINFO )
ELSE
*
* Use unblocked code to factorize columns k:n of A
*
CALL CSYTF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
$ IINFO )
KB = N - K + 1
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + K - 1
*
* Adjust IPIV
*
DO 30 J = K, K + KB - 1
IF( IPIV( J ).GT.0 ) THEN
IPIV( J ) = IPIV( J ) + K - 1
ELSE
IPIV( J ) = IPIV( J ) - K + 1
END IF
30 CONTINUE
*
* Increase K and return to the start of the main loop
*
K = K + KB
GO TO 20
*
END IF
*
40 CONTINUE
WORK( 1 ) = LWKOPT
RETURN
*
* End of CSYTRF_ROOK
*
END

451
lapack-netlib/SRC/csytri_rook.f Normal file
View File

@ -0,0 +1,451 @@
*> \brief \b CSYTRI_ROOK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CSYTRI_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csytri_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csytri_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csytri_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSYTRI_ROOK computes the inverse of a complex symmetric
*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T
*> computed by CSYTRF_ROOK.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the block diagonal matrix D and the multipliers
*> used to obtain the factor U or L as computed by CSYTRF_ROOK.
*>
*> On exit, if INFO = 0, the (symmetric) inverse of the original
*> matrix. If UPLO = 'U', the upper triangular part of the
*> inverse is formed and the part of A below the diagonal is not
*> referenced; if UPLO = 'L' the lower triangular part of the
*> inverse is formed and the part of A above the diagonal is
*> not referenced.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by CSYTRF_ROOK.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
*> inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexSYcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2011, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX CONE, CZERO
PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ),
$ CZERO = ( 0.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K, KP, KSTEP
COMPLEX AK, AKKP1, AKP1, D, T, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX CDOTU
EXTERNAL LSAME, CDOTU
* ..
* .. External Subroutines ..
EXTERNAL CCOPY, CSWAP, CSYMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CSYTRI_ROOK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
$ RETURN
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U**T.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 40
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = CONE / A( K, K )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL CSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - CDOTU( K-1, WORK, 1, A( 1, K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = A( K, K+1 )
AK = A( K, K ) / T
AKP1 = A( K+1, K+1 ) / T
AKKP1 = A( K, K+1 ) / T
D = T*( AK*AKP1-CONE )
A( K, K ) = AKP1 / D
A( K+1, K+1 ) = AK / D
A( K, K+1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL CSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - CDOTU( K-1, WORK, 1, A( 1, K ),
$ 1 )
A( K, K+1 ) = A( K, K+1 ) -
$ CDOTU( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
CALL CCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
CALL CSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO,
$ A( 1, K+1 ), 1 )
A( K+1, K+1 ) = A( K+1, K+1 ) -
$ CDOTU( K-1, WORK, 1, A( 1, K+1 ), 1 )
END IF
KSTEP = 2
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* Interchange rows and columns K and IPIV(K) in the leading
* submatrix A(1:k+1,1:k+1)
*
KP = IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.GT.1 )
$ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
CALL CSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
ELSE
*
* Interchange rows and columns K and K+1 with -IPIV(K) and
* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1)
*
KP = -IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.GT.1 )
$ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
CALL CSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
*
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
TEMP = A( K, K+1 )
A( K, K+1 ) = A( KP, K+1 )
A( KP, K+1 ) = TEMP
END IF
*
K = K + 1
KP = -IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.GT.1 )
$ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
CALL CSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
END IF
*
K = K + 1
GO TO 30
40 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L**T.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
50 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 60
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = CONE / A( K, K )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL CSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1,
$ CZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - CDOTU( N-K, WORK, 1, A( K+1, K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = A( K, K-1 )
AK = A( K-1, K-1 ) / T
AKP1 = A( K, K ) / T
AKKP1 = A( K, K-1 ) / T
D = T*( AK*AKP1-CONE )
A( K-1, K-1 ) = AKP1 / D
A( K, K ) = AK / D
A( K, K-1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL CSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1,
$ CZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - CDOTU( N-K, WORK, 1, A( K+1, K ),
$ 1 )
A( K, K-1 ) = A( K, K-1 ) -
$ CDOTU( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
$ 1 )
CALL CCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
CALL CSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1,
$ CZERO, A( K+1, K-1 ), 1 )
A( K-1, K-1 ) = A( K-1, K-1 ) -
$ CDOTU( N-K, WORK, 1, A( K+1, K-1 ), 1 )
END IF
KSTEP = 2
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* Interchange rows and columns K and IPIV(K) in the trailing
* submatrix A(k-1:n,k-1:n)
*
KP = IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.LT.N )
$ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
CALL CSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
ELSE
*
* Interchange rows and columns K and K-1 with -IPIV(K) and
* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
*
KP = -IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.LT.N )
$ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
CALL CSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
*
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
TEMP = A( K, K-1 )
A( K, K-1 ) = A( KP, K-1 )
A( KP, K-1 ) = TEMP
END IF
*
K = K - 1
KP = -IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.LT.N )
$ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
CALL CSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
END IF
*
K = K - 1
GO TO 50
60 CONTINUE
END IF
*
RETURN
*
* End of CSYTRI_ROOK
*
END

484
lapack-netlib/SRC/csytrs_rook.f Normal file
View File

@ -0,0 +1,484 @@
*> \brief \b CSYTRS_ROOK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CSYTRS_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csytrs_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csytrs_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csytrs_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSYTRS_ROOK solves a system of linear equations A*X = B with
*> a complex symmetric matrix A using the factorization A = U*D*U**T or
*> A = L*D*L**T computed by CSYTRF_ROOK.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by CSYTRF_ROOK.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by CSYTRF_ROOK.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension (LDB,NRHS)
*> On entry, the right hand side matrix B.
*> On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexSYcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2011, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX CONE
PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KP
COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL CGEMV, CGERU, CSCAL, CSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CSYTRS_ROOK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U**T.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL CGERU( K-1, NRHS, -CONE, A( 1, K ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL CSCAL( NRHS, CONE / A( K, K ), B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K-1 )
IF( KP.NE.K-1 )
$ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.GT.2 ) THEN
CALL CGERU( K-2, NRHS,-CONE, A( 1, K ), 1, B( K, 1 ),
$ LDB, B( 1, 1 ), LDB )
CALL CGERU( K-2, NRHS,-CONE, A( 1, K-1 ), 1, B( K-1, 1 ),
$ LDB, B( 1, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K-1, K )
AKM1 = A( K-1, K-1 ) / AKM1K
AK = A( K, K ) / AKM1K
DENOM = AKM1*AK - CONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / AKM1K
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U**T *X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U**T(K)), where U(K) is the transformation
* stored in column K of A.
*
IF( K.GT.1 )
$ CALL CGEMV( 'Transpose', K-1, NRHS, -CONE, B,
$ LDB, A( 1, K ), 1, CONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.GT.1 ) THEN
CALL CGEMV( 'Transpose', K-1, NRHS, -CONE, B,
$ LDB, A( 1, K ), 1, CONE, B( K, 1 ), LDB )
CALL CGEMV( 'Transpose', K-1, NRHS, -CONE, B,
$ LDB, A( 1, K+1 ), 1, CONE, B( K+1, 1 ), LDB )
END IF
*
* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K+1 )
IF( KP.NE.K+1 )
$ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L**T.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL CGERU( N-K, NRHS, -CONE, A( K+1, K ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL CSCAL( NRHS, CONE / A( K, K ), B( K, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1)
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K+1 )
IF( KP.NE.K+1 )
$ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL CGERU( N-K-1, NRHS,-CONE, A( K+2, K ), 1, B( K, 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL CGERU( N-K-1, NRHS,-CONE, A( K+2, K+1 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K+1, K )
AKM1 = A( K, K ) / AKM1K
AK = A( K+1, K+1 ) / AKM1K
DENOM = AKM1*AK - CONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / AKM1K
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L**T *X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L**T(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL CGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL CGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB )
CALL CGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ),
$ LDB, A( K+1, K-1 ), 1, CONE, B( K-1, 1 ),
$ LDB )
END IF
*
* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K-1 )
IF( KP.NE.K-1 )
$ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of CSYTRS_ROOK
*
END

20
lapack-netlib/SRC/ctpmqrt.f
View File

@ -175,7 +175,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@ -216,10 +216,10 @@
SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT,
$ A, LDA, B, LDB, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@ -235,7 +235,7 @@
* ..
* .. Local Scalars ..
LOGICAL LEFT, RIGHT, TRAN, NOTRAN
INTEGER I, IB, MB, LB, KF, Q
INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ
* ..
* .. External Functions ..
LOGICAL LSAME
@ -258,9 +258,11 @@
NOTRAN = LSAME( TRANS, 'N' )
*
IF ( LEFT ) THEN
Q = M
LDVQ = MAX( 1, M )
LDAQ = MAX( 1, K )
ELSE IF ( RIGHT ) THEN
Q = N
LDVQ = MAX( 1, N )
LDAQ = MAX( 1, M )
END IF
IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
INFO = -1
@ -274,13 +276,13 @@
INFO = -5
ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
INFO = -6
ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN
INFO = -7
ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
ELSE IF( LDV.LT.LDVQ ) THEN
INFO = -9
ELSE IF( LDT.LT.NB ) THEN
INFO = -11
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
ELSE IF( LDA.LT.LDAQ ) THEN
INFO = -13
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -15

10
lapack-netlib/SRC/ctpqrt.f
View File

@ -132,7 +132,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@ -189,10 +189,10 @@
SUBROUTINE CTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LDT, N, M, L, NB
@ -219,9 +219,9 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
INFO = -3
ELSE IF( NB.LT.1 .OR. NB.GT.N ) THEN
ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6

79
lapack-netlib/SRC/cunbdb.f
View File

@ -255,7 +255,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@ -287,10 +287,10 @@
$ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
$ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIGNS, TRANS
@ -420,19 +420,33 @@
THETA(I) = ATAN2( SCNRM2( M-P-I+1, X21(I,I), 1 ),
$ SCNRM2( P-I+1, X11(I,I), 1 ) )
*
IF( P .GT. I ) THEN
CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
ELSE IF ( P .EQ. I ) THEN
CALL CLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
END IF
X11(I,I) = ONE
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
IF ( M-P .GT. I ) THEN
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
$ TAUP2(I) )
ELSE IF ( M-P .EQ. I ) THEN
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1,
$ TAUP2(I) )
END IF
X21(I,I) = ONE
*
CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
$ X11(I,I+1), LDX11, WORK )
IF ( Q .GT. I ) THEN
CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1,
$ CONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK )
CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1,
$ CONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
CALL CLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
$ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK )
CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
$ X21(I,I+1), LDX21, WORK )
CALL CLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
$ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK )
END IF
*
IF( I .LT. Q ) THEN
CALL CSCAL( Q-I, CMPLX( -Z1*Z3*SIN(THETA(I)), 0.0E0 ),
@ -451,13 +465,25 @@
*
IF( I .LT. Q ) THEN
CALL CLACGV( Q-I, X11(I,I+1), LDX11 )
IF ( I .EQ. Q-1 ) THEN
CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11,
$ TAUQ1(I) )
ELSE
CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
$ TAUQ1(I) )
END IF
X11(I,I+1) = ONE
END IF
IF ( M-Q+1 .GT. I ) THEN
CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 )
IF ( M-Q .EQ. I ) THEN
CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
$ TAUQ2(I) )
ELSE
CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
$ TAUQ2(I) )
END IF
END IF
X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
@ -466,10 +492,14 @@
CALL CLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK )
END IF
IF ( P .GT. I ) THEN
CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
$ X12(I+1,I), LDX12, WORK )
CALL CLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
$ X22(I+1,I), LDX22, WORK )
END IF
IF ( M-P .GT. I ) THEN
CALL CLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
$ TAUQ2(I), X22(I+1,I), LDX22, WORK )
END IF
*
IF( I .LT. Q )
$ CALL CLACGV( Q-I, X11(I,I+1), LDX11 )
@ -484,12 +514,19 @@
CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4, 0.0E0 ), X12(I,I),
$ LDX12 )
CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 )
IF ( I .GE. M-Q ) THEN
CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
$ TAUQ2(I) )
ELSE
CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
$ TAUQ2(I) )
END IF
X12(I,I) = ONE
*
IF ( P .GT. I ) THEN
CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
$ X12(I+1,I), LDX12, WORK )
END IF
IF( M-P-Q .GE. 1 )
$ CALL CLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
$ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
@ -548,8 +585,13 @@
*
CALL CLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
X11(I,I) = ONE
IF ( I .EQ. M-P ) THEN
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
$ TAUP2(I) )
ELSE
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
$ TAUP2(I) )
END IF
X21(I,I) = ONE
*
CALL CLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
@ -594,9 +636,11 @@
END IF
CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, CONJG(TAUQ2(I)),
$ X12(I,I+1), LDX12, WORK )
IF ( M-P .GT. I ) THEN
CALL CLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
$ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK )
*
END IF
END DO
*
* Reduce columns Q + 1, ..., P of X12, X22
@ -607,8 +651,10 @@
CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
X12(I,I) = ONE
*
CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, CONJG(TAUQ2(I)),
$ X12(I,I+1), LDX12, WORK )
IF ( P .GT. I ) THEN
CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1,
$ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
END IF
IF( M-P-Q .GE. 1 )
$ CALL CLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
$ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22, WORK )
@ -624,10 +670,11 @@
CALL CLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
$ TAUQ2(P+I) )
X22(P+I,Q+I) = ONE
*
IF ( M-P-Q .NE. I ) THEN
CALL CLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
$ CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22, WORK )
*
$ CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22,
$ WORK )
END IF
END DO
*
END IF

327
lapack-netlib/SRC/cunbdb1.f Normal file
View File

@ -0,0 +1,327 @@
*> \brief \b CUNBDB1
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNBDB1 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb1.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb1.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb1.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
* REAL PHI(*), THETA(*)
* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
* $ X11(LDX11,*), X21(LDX21,*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> CUNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
*> matrix X with orthonomal columns:
*>
*> [ B11 ]
*> [ X11 ] [ P1 | ] [ 0 ]
*> [-----] = [---------] [-----] Q1**T .
*> [ X21 ] [ | P2 ] [ B21 ]
*> [ 0 ]
*>
*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
*> M-P, or M-Q. Routines CUNBDB2, CUNBDB3, and CUNBDB4 handle cases in
*> which Q is not the minimum dimension.
*>
*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
*> Householder vectors.
*>
*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
*> angles THETA, PHI.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows X11 plus the number of rows in X21.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is INTEGER
*> The number of rows in X11. 0 <= P <= M.
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is INTEGER
*> The number of columns in X11 and X21. 0 <= Q <=
*> MIN(P,M-P,M-Q).
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*> X11 is COMPLEX array, dimension (LDX11,Q)
*> On entry, the top block of the matrix X to be reduced. On
*> exit, the columns of tril(X11) specify reflectors for P1 and
*> the rows of triu(X11,1) specify reflectors for Q1.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*> LDX11 is INTEGER
*> The leading dimension of X11. LDX11 >= P.
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*> X21 is COMPLEX array, dimension (LDX21,Q)
*> On entry, the bottom block of the matrix X to be reduced. On
*> exit, the columns of tril(X21) specify reflectors for P2.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*> LDX21 is INTEGER
*> The leading dimension of X21. LDX21 >= M-P.
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*> THETA is REAL array, dimension (Q)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] PHI
*> \verbatim
*> PHI is REAL array, dimension (Q-1)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP1
*> \verbatim
*> TAUP1 is COMPLEX array, dimension (P)
*> The scalar factors of the elementary reflectors that define
*> P1.
*> \endverbatim
*>
*> \param[out] TAUP2
*> \verbatim
*> TAUP2 is COMPLEX array, dimension (M-P)
*> The scalar factors of the elementary reflectors that define
*> P2.
*> \endverbatim
*>
*> \param[out] TAUQ1
*> \verbatim
*> TAUQ1 is COMPLEX array, dimension (Q)
*> The scalar factors of the elementary reflectors that define
*> Q1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= M-Q.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup complexOTHERcomputational
*
*> \par Further Details:
* =====================
*> \verbatim
*>
*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
*> in each bidiagonal band is a product of a sine or cosine of a THETA
*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
*>
*> P1, P2, and Q1 are represented as products of elementary reflectors.
*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
*> and CUNGLQ.
*> \endverbatim
*
*> \par References:
* ================
*>
*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
REAL PHI(*), THETA(*)
COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
$ X11(LDX11,*), X21(LDX21,*)
* ..
*
* ====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER ( ONE = (1.0E0,0.0E0) )
* ..
* .. Local Scalars ..
REAL C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
$ LWORKMIN, LWORKOPT
LOGICAL LQUERY
* ..
* .. External Subroutines ..
EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, XERBLA
EXTERNAL CLACGV
* ..
* .. External Functions ..
REAL SCNRM2
EXTERNAL SCNRM2
* ..
* .. Intrinsic Function ..
INTRINSIC ATAN2, COS, MAX, SIN, SQRT
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
LQUERY = LWORK .EQ. -1
*
IF( M .LT. 0 ) THEN
INFO = -1
ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN
INFO = -2
ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN
INFO = -3
ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -5
ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -7
END IF
*
* Compute workspace
*
IF( INFO .EQ. 0 ) THEN
ILARF = 2
LLARF = MAX( P-1, M-P-1, Q-1 )
IORBDB5 = 2
LORBDB5 = Q-2
LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
LWORKMIN = LWORKOPT
WORK(1) = LWORKOPT
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'CUNBDB1', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Reduce columns 1, ..., Q of X11 and X21
*
DO I = 1, Q
*
CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
THETA(I) = ATAN2( REAL( X21(I,I) ), REAL( X11(I,I) ) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
X11(I,I) = ONE
X21(I,I) = ONE
CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
$ X11(I,I+1), LDX11, WORK(ILARF) )
CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
$ X21(I,I+1), LDX21, WORK(ILARF) )
*
IF( I .LT. Q ) THEN
CALL CSROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C,
$ S )
CALL CLACGV( Q-I, X21(I,I+1), LDX21 )
CALL CLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
S = REAL( X21(I,I+1) )
X21(I,I+1) = ONE
CALL CLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
$ X11(I+1,I+1), LDX11, WORK(ILARF) )
CALL CLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK(ILARF) )
CALL CLACGV( Q-I, X21(I,I+1), LDX21 )
C = SQRT( SCNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1),
$ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1),
$ 1 )**2 )
PHI(I) = ATAN2( S, C )
CALL CUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
$ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
$ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5,
$ CHILDINFO )
END IF
*
END DO
*
RETURN
*
* End of CUNBDB1
*
END

337
lapack-netlib/SRC/cunbdb2.f Normal file
View File

@ -0,0 +1,337 @@
*> \brief \b CUNBDB2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNBDB2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
* REAL PHI(*), THETA(*)
* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
* $ X11(LDX11,*), X21(LDX21,*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> CUNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
*> matrix X with orthonomal columns:
*>
*> [ B11 ]
*> [ X11 ] [ P1 | ] [ 0 ]
*> [-----] = [---------] [-----] Q1**T .
*> [ X21 ] [ | P2 ] [ B21 ]
*> [ 0 ]
*>
*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
*> Q, or M-Q. Routines CUNBDB1, CUNBDB3, and CUNBDB4 handle cases in
*> which P is not the minimum dimension.
*>
*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
*> Householder vectors.
*>
*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
*> angles THETA, PHI.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows X11 plus the number of rows in X21.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is INTEGER
*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is INTEGER
*> The number of columns in X11 and X21. 0 <= Q <= M.
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*> X11 is COMPLEX array, dimension (LDX11,Q)
*> On entry, the top block of the matrix X to be reduced. On
*> exit, the columns of tril(X11) specify reflectors for P1 and
*> the rows of triu(X11,1) specify reflectors for Q1.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*> LDX11 is INTEGER
*> The leading dimension of X11. LDX11 >= P.
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*> X21 is COMPLEX array, dimension (LDX21,Q)
*> On entry, the bottom block of the matrix X to be reduced. On
*> exit, the columns of tril(X21) specify reflectors for P2.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*> LDX21 is INTEGER
*> The leading dimension of X21. LDX21 >= M-P.
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*> THETA is REAL array, dimension (Q)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] PHI
*> \verbatim
*> PHI is REAL array, dimension (Q-1)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP1
*> \verbatim
*> TAUP1 is COMPLEX array, dimension (P)
*> The scalar factors of the elementary reflectors that define
*> P1.
*> \endverbatim
*>
*> \param[out] TAUP2
*> \verbatim
*> TAUP2 is COMPLEX array, dimension (M-P)
*> The scalar factors of the elementary reflectors that define
*> P2.
*> \endverbatim
*>
*> \param[out] TAUQ1
*> \verbatim
*> TAUQ1 is COMPLEX array, dimension (Q)
*> The scalar factors of the elementary reflectors that define
*> Q1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= M-Q.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*>
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup complexOTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
*> in each bidiagonal band is a product of a sine or cosine of a THETA
*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
*>
*> P1, P2, and Q1 are represented as products of elementary reflectors.
*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
*> and CUNGLQ.
*> \endverbatim
*
*> \par References:
* ================
*>
*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
REAL PHI(*), THETA(*)
COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
$ X11(LDX11,*), X21(LDX21,*)
* ..
*
* ====================================================================
*
* .. Parameters ..
COMPLEX NEGONE, ONE
PARAMETER ( NEGONE = (-1.0E0,0.0E0),
$ ONE = (1.0E0,0.0E0) )
* ..
* .. Local Scalars ..
REAL C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
$ LWORKMIN, LWORKOPT
LOGICAL LQUERY
* ..
* .. External Subroutines ..
EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, XERBLA
* ..
* .. External Functions ..
REAL SCNRM2
EXTERNAL SCNRM2
* ..
* .. Intrinsic Function ..
INTRINSIC ATAN2, COS, MAX, SIN, SQRT
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
LQUERY = LWORK .EQ. -1
*
IF( M .LT. 0 ) THEN
INFO = -1
ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
INFO = -2
ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
INFO = -3
ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -5
ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -7
END IF
*
* Compute workspace
*
IF( INFO .EQ. 0 ) THEN
ILARF = 2
LLARF = MAX( P-1, M-P, Q-1 )
IORBDB5 = 2
LORBDB5 = Q-1
LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
LWORKMIN = LWORKOPT
WORK(1) = LWORKOPT
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'CUNBDB2', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Reduce rows 1, ..., P of X11 and X21
*
DO I = 1, P
*
IF( I .GT. 1 ) THEN
CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C,
$ S )
END IF
CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
C = REAL( X11(I,I) )
X11(I,I) = ONE
CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X11(I+1,I), LDX11, WORK(ILARF) )
CALL CLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X21(I,I), LDX21, WORK(ILARF) )
CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
S = SQRT( SCNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
$ 1 )**2 + SCNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 )
THETA(I) = ATAN2( S, C )
*
CALL CUNBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
$ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
$ WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL CSCAL( P-I, NEGONE, X11(I+1,I), 1 )
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
IF( I .LT. P ) THEN
CALL CLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
PHI(I) = ATAN2( REAL( X11(I+1,I) ), REAL( X21(I,I) ) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
X11(I+1,I) = ONE
CALL CLARF( 'L', P-I, Q-I, X11(I+1,I), 1, CONJG(TAUP1(I)),
$ X11(I+1,I+1), LDX11, WORK(ILARF) )
END IF
X21(I,I) = ONE
CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
$ X21(I,I+1), LDX21, WORK(ILARF) )
*
END DO
*
* Reduce the bottom-right portion of X21 to the identity matrix
*
DO I = P + 1, Q
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
X21(I,I) = ONE
CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
$ X21(I,I+1), LDX21, WORK(ILARF) )
END DO
*
RETURN
*
* End of CUNBDB2
*
END

336
lapack-netlib/SRC/cunbdb3.f Normal file
View File

@ -0,0 +1,336 @@
*> \brief \b CUNBDB3
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNBDB3 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb3.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb3.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb3.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
* REAL PHI(*), THETA(*)
* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
* $ X11(LDX11,*), X21(LDX21,*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> CUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
*> matrix X with orthonomal columns:
*>
*> [ B11 ]
*> [ X11 ] [ P1 | ] [ 0 ]
*> [-----] = [---------] [-----] Q1**T .
*> [ X21 ] [ | P2 ] [ B21 ]
*> [ 0 ]
*>
*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
*> Q, or M-Q. Routines CUNBDB1, CUNBDB2, and CUNBDB4 handle cases in
*> which M-P is not the minimum dimension.
*>
*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
*> Householder vectors.
*>
*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
*> implicitly by angles THETA, PHI.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows X11 plus the number of rows in X21.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is INTEGER
*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is INTEGER
*> The number of columns in X11 and X21. 0 <= Q <= M.
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*> X11 is COMPLEX array, dimension (LDX11,Q)
*> On entry, the top block of the matrix X to be reduced. On
*> exit, the columns of tril(X11) specify reflectors for P1 and
*> the rows of triu(X11,1) specify reflectors for Q1.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*> LDX11 is INTEGER
*> The leading dimension of X11. LDX11 >= P.
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*> X21 is COMPLEX array, dimension (LDX21,Q)
*> On entry, the bottom block of the matrix X to be reduced. On
*> exit, the columns of tril(X21) specify reflectors for P2.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*> LDX21 is INTEGER
*> The leading dimension of X21. LDX21 >= M-P.
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*> THETA is REAL array, dimension (Q)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] PHI
*> \verbatim
*> PHI is REAL array, dimension (Q-1)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP1
*> \verbatim
*> TAUP1 is COMPLEX array, dimension (P)
*> The scalar factors of the elementary reflectors that define
*> P1.
*> \endverbatim
*>
*> \param[out] TAUP2
*> \verbatim
*> TAUP2 is COMPLEX array, dimension (M-P)
*> The scalar factors of the elementary reflectors that define
*> P2.
*> \endverbatim
*>
*> \param[out] TAUQ1
*> \verbatim
*> TAUQ1 is COMPLEX array, dimension (Q)
*> The scalar factors of the elementary reflectors that define
*> Q1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= M-Q.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*>
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup complexOTHERcomputational
*
*> \par Further Details:
* =====================
*> \verbatim
*>
*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
*> in each bidiagonal band is a product of a sine or cosine of a THETA
*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
*>
*> P1, P2, and Q1 are represented as products of elementary reflectors.
*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
*> and CUNGLQ.
*> \endverbatim
*
*> \par References:
* ================
*>
*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
REAL PHI(*), THETA(*)
COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
$ X11(LDX11,*), X21(LDX21,*)
* ..
*
* ====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER ( ONE = (1.0E0,0.0E0) )
* ..
* .. Local Scalars ..
REAL C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
$ LWORKMIN, LWORKOPT
LOGICAL LQUERY
* ..
* .. External Subroutines ..
EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, XERBLA
* ..
* .. External Functions ..
REAL SCNRM2
EXTERNAL SCNRM2
* ..
* .. Intrinsic Function ..
INTRINSIC ATAN2, COS, MAX, SIN, SQRT
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
LQUERY = LWORK .EQ. -1
*
IF( M .LT. 0 ) THEN
INFO = -1
ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN
INFO = -2
ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN
INFO = -3
ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -5
ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -7
END IF
*
* Compute workspace
*
IF( INFO .EQ. 0 ) THEN
ILARF = 2
LLARF = MAX( P, M-P-1, Q-1 )
IORBDB5 = 2
LORBDB5 = Q-1
LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
LWORKMIN = LWORKOPT
WORK(1) = LWORKOPT
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'CUNBDB3', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Reduce rows 1, ..., M-P of X11 and X21
*
DO I = 1, M-P
*
IF( I .GT. 1 ) THEN
CALL CSROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C,
$ S )
END IF
*
CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
S = REAL( X21(I,I) )
X21(I,I) = ONE
CALL CLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X11(I,I), LDX11, WORK(ILARF) )
CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X21(I+1,I), LDX21, WORK(ILARF) )
CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
C = SQRT( SCNRM2( P-I+1, X11(I,I), 1, X11(I,I),
$ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 )
THETA(I) = ATAN2( S, C )
*
CALL CUNBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
$ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
$ WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
IF( I .LT. M-P ) THEN
CALL CLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
PHI(I) = ATAN2( REAL( X21(I+1,I) ), REAL( X11(I,I) ) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
X21(I+1,I) = ONE
CALL CLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, CONJG(TAUP2(I)),
$ X21(I+1,I+1), LDX21, WORK(ILARF) )
END IF
X11(I,I) = ONE
CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
$ X11(I,I+1), LDX11, WORK(ILARF) )
*
END DO
*
* Reduce the bottom-right portion of X11 to the identity matrix
*
DO I = M-P + 1, Q
CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
X11(I,I) = ONE
CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
$ X11(I,I+1), LDX11, WORK(ILARF) )
END DO
*
RETURN
*
* End of CUNBDB3
*
END

385
lapack-netlib/SRC/cunbdb4.f Normal file
View File

@ -0,0 +1,385 @@
*> \brief \b CUNBDB4
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNBDB4 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb4.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb4.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb4.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
* REAL PHI(*), THETA(*)
* COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
* $ WORK(*), X11(LDX11,*), X21(LDX21,*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> CUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
*> matrix X with orthonomal columns:
*>
*> [ B11 ]
*> [ X11 ] [ P1 | ] [ 0 ]
*> [-----] = [---------] [-----] Q1**T .
*> [ X21 ] [ | P2 ] [ B21 ]
*> [ 0 ]
*>
*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
*> M-P, or Q. Routines CUNBDB1, CUNBDB2, and CUNBDB3 handle cases in
*> which M-Q is not the minimum dimension.
*>
*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
*> Householder vectors.
*>
*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
*> implicitly by angles THETA, PHI.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows X11 plus the number of rows in X21.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is INTEGER
*> The number of rows in X11. 0 <= P <= M.
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is INTEGER
*> The number of columns in X11 and X21. 0 <= Q <= M and
*> M-Q <= min(P,M-P,Q).
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*> X11 is COMPLEX array, dimension (LDX11,Q)
*> On entry, the top block of the matrix X to be reduced. On
*> exit, the columns of tril(X11) specify reflectors for P1 and
*> the rows of triu(X11,1) specify reflectors for Q1.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*> LDX11 is INTEGER
*> The leading dimension of X11. LDX11 >= P.
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*> X21 is COMPLEX array, dimension (LDX21,Q)
*> On entry, the bottom block of the matrix X to be reduced. On
*> exit, the columns of tril(X21) specify reflectors for P2.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*> LDX21 is INTEGER
*> The leading dimension of X21. LDX21 >= M-P.
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*> THETA is REAL array, dimension (Q)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] PHI
*> \verbatim
*> PHI is REAL array, dimension (Q-1)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP1
*> \verbatim
*> TAUP1 is COMPLEX array, dimension (P)
*> The scalar factors of the elementary reflectors that define
*> P1.
*> \endverbatim
*>
*> \param[out] TAUP2
*> \verbatim
*> TAUP2 is COMPLEX array, dimension (M-P)
*> The scalar factors of the elementary reflectors that define
*> P2.
*> \endverbatim
*>
*> \param[out] TAUQ1
*> \verbatim
*> TAUQ1 is COMPLEX array, dimension (Q)
*> The scalar factors of the elementary reflectors that define
*> Q1.
*> \endverbatim
*>
*> \param[out] PHANTOM
*> \verbatim
*> PHANTOM is COMPLEX array, dimension (M)
*> The routine computes an M-by-1 column vector Y that is
*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
*> Y(P+1:M), respectively.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= M-Q.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup complexOTHERcomputational
*
*> \par Further Details:
* =====================
*> \verbatim
*>
*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
*> in each bidiagonal band is a product of a sine or cosine of a THETA
*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
*>
*> P1, P2, and Q1 are represented as products of elementary reflectors.
*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
*> and CUNGLQ.
*> \endverbatim
*
*> \par References:
* ================
*>
*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
REAL PHI(*), THETA(*)
COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
$ WORK(*), X11(LDX11,*), X21(LDX21,*)
* ..
*
* ====================================================================
*
* .. Parameters ..
COMPLEX NEGONE, ONE, ZERO
PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0),
$ ZERO = (0.0E0,0.0E0) )
* ..
* .. Local Scalars ..
REAL C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
$ LORBDB5, LWORKMIN, LWORKOPT
LOGICAL LQUERY
* ..
* .. External Subroutines ..
EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, XERBLA
* ..
* .. External Functions ..
REAL SCNRM2
EXTERNAL SCNRM2
* ..
* .. Intrinsic Function ..
INTRINSIC ATAN2, COS, MAX, SIN, SQRT
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
LQUERY = LWORK .EQ. -1
*
IF( M .LT. 0 ) THEN
INFO = -1
ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN
INFO = -2
ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN
INFO = -3
ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -5
ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -7
END IF
*
* Compute workspace
*
IF( INFO .EQ. 0 ) THEN
ILARF = 2
LLARF = MAX( Q-1, P-1, M-P-1 )
IORBDB5 = 2
LORBDB5 = Q
LWORKOPT = ILARF + LLARF - 1
LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
LWORKMIN = LWORKOPT
WORK(1) = LWORKOPT
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'CUNBDB4', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Reduce columns 1, ..., M-Q of X11 and X21
*
DO I = 1, M-Q
*
IF( I .EQ. 1 ) THEN
DO J = 1, M
PHANTOM(J) = ZERO
END DO
CALL CUNBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1,
$ X11, LDX11, X21, LDX21, WORK(IORBDB5),
$ LORBDB5, CHILDINFO )
CALL CSCAL( P, NEGONE, PHANTOM(1), 1 )
CALL CLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
CALL CLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
THETA(I) = ATAN2( REAL( PHANTOM(1) ), REAL( PHANTOM(P+1) ) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
PHANTOM(1) = ONE
PHANTOM(P+1) = ONE
CALL CLARF( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), X11,
$ LDX11, WORK(ILARF) )
CALL CLARF( 'L', M-P, Q, PHANTOM(P+1), 1, CONJG(TAUP2(1)),
$ X21, LDX21, WORK(ILARF) )
ELSE
CALL CUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
$ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
$ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL CSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
CALL CLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
CALL CLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
$ TAUP2(I) )
THETA(I) = ATAN2( REAL( X11(I,I-1) ), REAL( X21(I,I-1) ) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
X11(I,I-1) = ONE
X21(I,I-1) = ONE
CALL CLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1,
$ CONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) )
CALL CLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
$ CONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) )
END IF
*
CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
C = REAL( X21(I,I) )
X21(I,I) = ONE
CALL CLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X11(I+1,I), LDX11, WORK(ILARF) )
CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X21(I+1,I), LDX21, WORK(ILARF) )
CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
IF( I .LT. M-Q ) THEN
S = SQRT( SCNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
$ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I),
$ 1 )**2 )
PHI(I) = ATAN2( S, C )
END IF
*
END DO
*
* Reduce the bottom-right portion of X11 to [ I 0 ]
*
DO I = M - Q + 1, P
CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
X11(I,I) = ONE
CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X11(I+1,I), LDX11, WORK(ILARF) )
CALL CLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X21(M-Q+1,I), LDX21, WORK(ILARF) )
CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
END DO
*
* Reduce the bottom-right portion of X21 to [ 0 I ]
*
DO I = P + 1, Q
CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
CALL CLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
$ TAUQ1(I) )
X21(M-Q+I-P,I) = ONE
CALL CLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
$ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
END DO
*
RETURN
*
* End of CUNBDB4
*
END

274
lapack-netlib/SRC/cunbdb5.f Normal file
View File

@ -0,0 +1,274 @@
*> \brief \b CUNBDB5
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNBDB5 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb5.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb5.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb5.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
* LDQ2, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
* $ N
* ..
* .. Array Arguments ..
* COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> CUNBDB5 orthogonalizes the column vector
*> X = [ X1 ]
*> [ X2 ]
*> with respect to the columns of
*> Q = [ Q1 ] .
*> [ Q2 ]
*> The columns of Q must be orthonormal.
*>
*> If the projection is zero according to Kahan's "twice is enough"
*> criterion, then some other vector from the orthogonal complement
*> is returned. This vector is chosen in an arbitrary but deterministic
*> way.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M1
*> \verbatim
*> M1 is INTEGER
*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
*> \endverbatim
*>
*> \param[in] M2
*> \verbatim
*> M2 is INTEGER
*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in Q1 and Q2. 0 <= N.
*> \endverbatim
*>
*> \param[in,out] X1
*> \verbatim
*> X1 is COMPLEX array, dimension (M1)
*> On entry, the top part of the vector to be orthogonalized.
*> On exit, the top part of the projected vector.
*> \endverbatim
*>
*> \param[in] INCX1
*> \verbatim
*> INCX1 is INTEGER
*> Increment for entries of X1.
*> \endverbatim
*>
*> \param[in,out] X2
*> \verbatim
*> X2 is COMPLEX array, dimension (M2)
*> On entry, the bottom part of the vector to be
*> orthogonalized. On exit, the bottom part of the projected
*> vector.
*> \endverbatim
*>
*> \param[in] INCX2
*> \verbatim
*> INCX2 is INTEGER
*> Increment for entries of X2.
*> \endverbatim
*>
*> \param[in] Q1
*> \verbatim
*> Q1 is COMPLEX array, dimension (LDQ1, N)
*> The top part of the orthonormal basis matrix.
*> \endverbatim
*>
*> \param[in] LDQ1
*> \verbatim
*> LDQ1 is INTEGER
*> The leading dimension of Q1. LDQ1 >= M1.
*> \endverbatim
*>
*> \param[in] Q2
*> \verbatim
*> Q2 is COMPLEX array, dimension (LDQ2, N)
*> The bottom part of the orthonormal basis matrix.
*> \endverbatim
*>
*> \param[in] LDQ2
*> \verbatim
*> LDQ2 is INTEGER
*> The leading dimension of Q2. LDQ2 >= M2.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= N.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup complexOTHERcomputational
*
* =====================================================================
SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
$ LDQ2, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
$ N
* ..
* .. Array Arguments ..
COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE, ZERO
PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) )
* ..
* .. Local Scalars ..
INTEGER CHILDINFO, I, J
* ..
* .. External Subroutines ..
EXTERNAL CUNBDB6, XERBLA
* ..
* .. External Functions ..
REAL SCNRM2
EXTERNAL SCNRM2
* ..
* .. Intrinsic Function ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
IF( M1 .LT. 0 ) THEN
INFO = -1
ELSE IF( M2 .LT. 0 ) THEN
INFO = -2
ELSE IF( N .LT. 0 ) THEN
INFO = -3
ELSE IF( INCX1 .LT. 1 ) THEN
INFO = -5
ELSE IF( INCX2 .LT. 1 ) THEN
INFO = -7
ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
INFO = -9
ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
INFO = -11
ELSE IF( LWORK .LT. N ) THEN
INFO = -13
END IF
*
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'CUNBDB5', -INFO )
RETURN
END IF
*
* Project X onto the orthogonal complement of Q
*
CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2,
$ WORK, LWORK, CHILDINFO )
*
* If the projection is nonzero, then return
*
IF( SCNRM2(M1,X1,INCX1) .NE. ZERO
$ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
RETURN
END IF
*
* Project each standard basis vector e_1,...,e_M1 in turn, stopping
* when a nonzero projection is found
*
DO I = 1, M1
DO J = 1, M1
X1(J) = ZERO
END DO
X1(I) = ONE
DO J = 1, M2
X2(J) = ZERO
END DO
CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
$ LDQ2, WORK, LWORK, CHILDINFO )
IF( SCNRM2(M1,X1,INCX1) .NE. ZERO
$ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
RETURN
END IF
END DO
*
* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
* stopping when a nonzero projection is found
*
DO I = 1, M2
DO J = 1, M1
X1(J) = ZERO
END DO
DO J = 1, M2
X2(J) = ZERO
END DO
X2(I) = ONE
CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
$ LDQ2, WORK, LWORK, CHILDINFO )
IF( SCNRM2(M1,X1,INCX1) .NE. ZERO
$ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
RETURN
END IF
END DO
*
RETURN
*
* End of CUNBDB5
*
END

313
lapack-netlib/SRC/cunbdb6.f Normal file
View File

@ -0,0 +1,313 @@
*> \brief \b CUNBDB6
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNBDB6 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb6.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb6.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb6.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
* LDQ2, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
* $ N
* ..
* .. Array Arguments ..
* COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> CUNBDB6 orthogonalizes the column vector
*> X = [ X1 ]
*> [ X2 ]
*> with respect to the columns of
*> Q = [ Q1 ] .
*> [ Q2 ]
*> The columns of Q must be orthonormal.
*>
*> If the projection is zero according to Kahan's "twice is enough"
*> criterion, then the zero vector is returned.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M1
*> \verbatim
*> M1 is INTEGER
*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
*> \endverbatim
*>
*> \param[in] M2
*> \verbatim
*> M2 is INTEGER
*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in Q1 and Q2. 0 <= N.
*> \endverbatim
*>
*> \param[in,out] X1
*> \verbatim
*> X1 is COMPLEX array, dimension (M1)
*> On entry, the top part of the vector to be orthogonalized.
*> On exit, the top part of the projected vector.
*> \endverbatim
*>
*> \param[in] INCX1
*> \verbatim
*> INCX1 is INTEGER
*> Increment for entries of X1.
*> \endverbatim
*>
*> \param[in,out] X2
*> \verbatim
*> X2 is COMPLEX array, dimension (M2)
*> On entry, the bottom part of the vector to be
*> orthogonalized. On exit, the bottom part of the projected
*> vector.
*> \endverbatim
*>
*> \param[in] INCX2
*> \verbatim
*> INCX2 is INTEGER
*> Increment for entries of X2.
*> \endverbatim
*>
*> \param[in] Q1
*> \verbatim
*> Q1 is COMPLEX array, dimension (LDQ1, N)
*> The top part of the orthonormal basis matrix.
*> \endverbatim
*>
*> \param[in] LDQ1
*> \verbatim
*> LDQ1 is INTEGER
*> The leading dimension of Q1. LDQ1 >= M1.
*> \endverbatim
*>
*> \param[in] Q2
*> \verbatim
*> Q2 is COMPLEX array, dimension (LDQ2, N)
*> The bottom part of the orthonormal basis matrix.
*> \endverbatim
*>
*> \param[in] LDQ2
*> \verbatim
*> LDQ2 is INTEGER
*> The leading dimension of Q2. LDQ2 >= M2.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= N.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup complexOTHERcomputational
*
* =====================================================================
SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
$ LDQ2, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
$ N
* ..
* .. Array Arguments ..
COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ALPHASQ, REALONE, REALZERO
PARAMETER ( ALPHASQ = 0.01E0, REALONE = 1.0E0,
$ REALZERO = 0.0E0 )
COMPLEX NEGONE, ONE, ZERO
PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0),
$ ZERO = (0.0E0,0.0E0) )
* ..
* .. Local Scalars ..
INTEGER I
REAL NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
* ..
* .. External Subroutines ..
EXTERNAL CGEMV, CLASSQ, XERBLA
* ..
* .. Intrinsic Function ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
IF( M1 .LT. 0 ) THEN
INFO = -1
ELSE IF( M2 .LT. 0 ) THEN
INFO = -2
ELSE IF( N .LT. 0 ) THEN
INFO = -3
ELSE IF( INCX1 .LT. 1 ) THEN
INFO = -5
ELSE IF( INCX2 .LT. 1 ) THEN
INFO = -7
ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
INFO = -9
ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
INFO = -11
ELSE IF( LWORK .LT. N ) THEN
INFO = -13
END IF
*
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'CUNBDB6', -INFO )
RETURN
END IF
*
* First, project X onto the orthogonal complement of Q's column
* space
*
SCL1 = REALZERO
SSQ1 = REALONE
CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
SCL2 = REALZERO
SSQ2 = REALONE
CALL CLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
*
IF( M1 .EQ. 0 ) THEN
DO I = 1, N
WORK(I) = ZERO
END DO
ELSE
CALL CGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
$ 1 )
END IF
*
CALL CGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
*
CALL CGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
$ INCX1 )
CALL CGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
$ INCX2 )
*
SCL1 = REALZERO
SSQ1 = REALONE
CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
SCL2 = REALZERO
SSQ2 = REALONE
CALL CLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
*
* If projection is sufficiently large in norm, then stop.
* If projection is zero, then stop.
* Otherwise, project again.
*
IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
RETURN
END IF
*
IF( NORMSQ2 .EQ. ZERO ) THEN
RETURN
END IF
*
NORMSQ1 = NORMSQ2
*
DO I = 1, N
WORK(I) = ZERO
END DO
*
IF( M1 .EQ. 0 ) THEN
DO I = 1, N
WORK(I) = ZERO
END DO
ELSE
CALL CGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
$ 1 )
END IF
*
CALL CGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
*
CALL CGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
$ INCX1 )
CALL CGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
$ INCX2 )
*
SCL1 = REALZERO
SSQ1 = REALONE
CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
SCL2 = REALZERO
SSQ2 = REALONE
CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
*
* If second projection is sufficiently large in norm, then do
* nothing more. Alternatively, if it shrunk significantly, then
* truncate it to zero.
*
IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
DO I = 1, M1
X1(I) = ZERO
END DO
DO I = 1, M2
X2(I) = ZERO
END DO
END IF
*
RETURN
*
* End of CUNBDB6
*
END

50
lapack-netlib/SRC/cuncsd.f
View File

@ -308,7 +308,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup complexOTHERcomputational
*
@ -320,10 +320,10 @@
$ LDV2T, WORK, LWORK, RWORK, LRWORK,
$ IWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS
@ -356,7 +356,7 @@
$ LBBCSDWORKOPT, LORBDBWORK, LORBDBWORKMIN,
$ LORBDBWORKOPT, LORGLQWORK, LORGLQWORKMIN,
$ LORGLQWORKOPT, LORGQRWORK, LORGQRWORKMIN,
$ LORGQRWORKOPT, LWORKMIN, LWORKOPT
$ LORGQRWORKOPT, LWORKMIN, LWORKOPT, P1, Q1
LOGICAL COLMAJOR, DEFAULTSIGNS, LQUERY, WANTU1, WANTU2,
$ WANTV1T, WANTV2T
INTEGER LRWORKMIN, LRWORKOPT
@ -392,9 +392,22 @@
INFO = -8
ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
INFO = -9
ELSE IF( ( COLMAJOR .AND. LDX11 .LT. MAX(1,P) ) .OR.
$ ( .NOT.COLMAJOR .AND. LDX11 .LT. MAX(1,Q) ) ) THEN
ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -11
ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN
INFO = -11
ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN
INFO = -13
ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN
INFO = -13
ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -15
ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN
INFO = -15
ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN
INFO = -17
ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN
INFO = -17
ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
INFO = -20
ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN
@ -458,9 +471,10 @@
IB22D = IB21E + MAX( 1, Q - 1 )
IB22E = IB22D + MAX( 1, Q )
IBBCSD = IB22E + MAX( 1, Q - 1 )
CALL CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, 0,
$ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, 0,
$ 0, 0, 0, 0, 0, 0, 0, RWORK, -1, CHILDINFO )
CALL CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q,
$ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T,
$ V2T, LDV2T, THETA, THETA, THETA, THETA, THETA,
$ THETA, THETA, THETA, RWORK, -1, CHILDINFO )
LBBCSDWORKOPT = INT( RWORK(1) )
LBBCSDWORKMIN = LBBCSDWORKOPT
LRWORKOPT = IBBCSD + LBBCSDWORKOPT - 1
@ -474,19 +488,19 @@
ITAUQ1 = ITAUP2 + MAX( 1, M - P )
ITAUQ2 = ITAUQ1 + MAX( 1, Q )
IORGQR = ITAUQ2 + MAX( 1, M - Q )
CALL CUNGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1,
CALL CUNGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), U1, WORK, -1,
$ CHILDINFO )
LORGQRWORKOPT = INT( WORK(1) )
LORGQRWORKMIN = MAX( 1, M - Q )
IORGLQ = ITAUQ2 + MAX( 1, M - Q )
CALL CUNGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1,
CALL CUNGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), U1, WORK, -1,
$ CHILDINFO )
LORGLQWORKOPT = INT( WORK(1) )
LORGLQWORKMIN = MAX( 1, M - Q )
IORBDB = ITAUQ2 + MAX( 1, M - Q )
CALL CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ X21, LDX21, X22, LDX22, 0, 0, 0, 0, 0, 0, WORK,
$ -1, CHILDINFO )
$ X21, LDX21, X22, LDX22, THETA, THETA, U1, U2,
$ V1T, V2T, WORK, -1, CHILDINFO )
LORBDBWORKOPT = INT( WORK(1) )
LORBDBWORKMIN = LORBDBWORKOPT
LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT,
@ -551,11 +565,15 @@
END IF
IF( WANTV2T .AND. M-Q .GT. 0 ) THEN
CALL CLACPY( 'U', P, M-Q, X12, LDX12, V2T, LDV2T )
IF( M-P .GT. Q ) THEN
CALL CLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22,
$ V2T(P+1,P+1), LDV2T )
END IF
IF( M .GT. Q ) THEN
CALL CUNGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
$ WORK(IORGLQ), LORGLQWORK, INFO )
END IF
END IF
ELSE
IF( WANTU1 .AND. P .GT. 0 ) THEN
CALL CLACPY( 'U', Q, P, X11, LDX11, U1, LDU1 )
@ -579,9 +597,13 @@
$ WORK(IORGQR), LORGQRWORK, INFO )
END IF
IF( WANTV2T .AND. M-Q .GT. 0 ) THEN
P1 = MIN( P+1, M )
Q1 = MIN( Q+1, M )
CALL CLACPY( 'L', M-Q, P, X12, LDX12, V2T, LDV2T )
CALL CLACPY( 'L', M-P-Q, M-P-Q, X22(P+1,Q+1), LDX22,
IF ( M .GT. P+Q ) THEN
CALL CLACPY( 'L', M-P-Q, M-P-Q, X22(P1,Q1), LDX22,
$ V2T(P+1,P+1), LDV2T )
END IF
CALL CUNGQR( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
$ WORK(IORGQR), LORGQRWORK, INFO )
END IF

757
lapack-netlib/SRC/cuncsd2by1.f Normal file
View File

@ -0,0 +1,757 @@
*> \brief \b CUNCSD2BY1
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNCSD2BY1 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cuncsd2by1.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cuncsd2by1.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cuncsd2by1.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
* LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBU1, JOBU2, JOBV1T
* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
* $ M, P, Q
* INTEGER LRWORK, LRWORKMIN, LRWORKOPT
* ..
* .. Array Arguments ..
* REAL RWORK(*)
* REAL THETA(*)
* COMPLEX U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
* $ X11(LDX11,*), X21(LDX21,*)
* INTEGER IWORK(*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> CUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
*> orthonormal columns that has been partitioned into a 2-by-1 block
*> structure:
*>
*> [ I 0 0 ]
*> [ 0 C 0 ]
*> [ X11 ] [ U1 | ] [ 0 0 0 ]
*> X = [-----] = [---------] [----------] V1**T .
*> [ X21 ] [ | U2 ] [ 0 0 0 ]
*> [ 0 S 0 ]
*> [ 0 0 I ]
*>
*> X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,
*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
*> which R = MIN(P,M-P,Q,M-Q).
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBU1
*> \verbatim
*> JOBU1 is CHARACTER
*> = 'Y': U1 is computed;
*> otherwise: U1 is not computed.
*> \endverbatim
*>
*> \param[in] JOBU2
*> \verbatim
*> JOBU2 is CHARACTER
*> = 'Y': U2 is computed;
*> otherwise: U2 is not computed.
*> \endverbatim
*>
*> \param[in] JOBV1T
*> \verbatim
*> JOBV1T is CHARACTER
*> = 'Y': V1T is computed;
*> otherwise: V1T is not computed.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows and columns in X.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is INTEGER
*> The number of rows in X11 and X12. 0 <= P <= M.
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is INTEGER
*> The number of columns in X11 and X21. 0 <= Q <= M.
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*> X11 is COMPLEX array, dimension (LDX11,Q)
*> On entry, part of the unitary matrix whose CSD is
*> desired.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*> LDX11 is INTEGER
*> The leading dimension of X11. LDX11 >= MAX(1,P).
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*> X21 is COMPLEX array, dimension (LDX21,Q)
*> On entry, part of the unitary matrix whose CSD is
*> desired.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*> LDX21 is INTEGER
*> The leading dimension of X21. LDX21 >= MAX(1,M-P).
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*> THETA is COMPLEX array, dimension (R), in which R =
*> MIN(P,M-P,Q,M-Q).
*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
*> \endverbatim
*>
*> \param[out] U1
*> \verbatim
*> U1 is COMPLEX array, dimension (P)
*> If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.
*> \endverbatim
*>
*> \param[in] LDU1
*> \verbatim
*> LDU1 is INTEGER
*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
*> MAX(1,P).
*> \endverbatim
*>
*> \param[out] U2
*> \verbatim
*> U2 is COMPLEX array, dimension (M-P)
*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary
*> matrix U2.
*> \endverbatim
*>
*> \param[in] LDU2
*> \verbatim
*> LDU2 is INTEGER
*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
*> MAX(1,M-P).
*> \endverbatim
*>
*> \param[out] V1T
*> \verbatim
*> V1T is COMPLEX array, dimension (Q)
*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary
*> matrix V1**T.
*> \endverbatim
*>
*> \param[in] LDV1T
*> \verbatim
*> LDV1T is INTEGER
*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
*> MAX(1,Q).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
*> define the matrix in intermediate bidiagonal-block form
*> remaining after nonconvergence. INFO specifies the number
*> of nonzero PHI's.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> \endverbatim
*> \verbatim
*> 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.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is REAL array, dimension (MAX(1,LRWORK))
*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
*> If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),
*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
*> define the matrix in intermediate bidiagonal-block form
*> remaining after nonconvergence. INFO specifies the number
*> of nonzero PHI's.
*> \endverbatim
*>
*> \param[in] LRWORK
*> \verbatim
*> LRWORK is INTEGER
*> The dimension of the array RWORK.
*>
*> If LRWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the RWORK array, returns
*> this value as the first entry of the work array, and no error
*> message related to LRWORK is issued by XERBLA.
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
*> \endverbatim
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> > 0: CBBCSD did not converge. See the description of WORK
*> above for details.
*> \endverbatim
*
*> \par References:
*> ================
*>
*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*> Algorithms, 50(1):33-65, 2009.
*>
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup complexOTHERcomputational
*
* =====================================================================
SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
$ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
$ LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T
INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
$ M, P, Q
INTEGER LRWORK, LRWORKMIN, LRWORKOPT
* ..
* .. Array Arguments ..
REAL RWORK(*)
REAL THETA(*)
COMPLEX U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
$ X11(LDX11,*), X21(LDX21,*)
INTEGER IWORK(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE, ZERO
PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) )
* ..
* .. Local Scalars ..
INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
$ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
$ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
$ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
$ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
$ LWORKMIN, LWORKOPT, R
LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
* ..
* .. External Subroutines ..
EXTERNAL CBBCSD, CCOPY, CLACPY, CLAPMR, CLAPMT, CUNBDB1,
$ CUNBDB2, CUNBDB3, CUNBDB4, CUNGLQ, CUNGQR,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Function ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
WANTU1 = LSAME( JOBU1, 'Y' )
WANTU2 = LSAME( JOBU2, 'Y' )
WANTV1T = LSAME( JOBV1T, 'Y' )
LQUERY = LWORK .EQ. -1
*
IF( M .LT. 0 ) THEN
INFO = -4
ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
INFO = -5
ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
INFO = -6
ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -8
ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -10
ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
INFO = -13
ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN
INFO = -15
ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN
INFO = -17
END IF
*
R = MIN( P, M-P, Q, M-Q )
*
* Compute workspace
*
* WORK layout:
* |-----------------------------------------|
* | LWORKOPT (1) |
* |-----------------------------------------|
* | TAUP1 (MAX(1,P)) |
* | TAUP2 (MAX(1,M-P)) |
* | TAUQ1 (MAX(1,Q)) |
* |-----------------------------------------|
* | CUNBDB WORK | CUNGQR WORK | CUNGLQ WORK |
* | | | |
* | | | |
* | | | |
* | | | |
* |-----------------------------------------|
* RWORK layout:
* |------------------|
* | LRWORKOPT (1) |
* |------------------|
* | PHI (MAX(1,R-1)) |
* |------------------|
* | B11D (R) |
* | B11E (R-1) |
* | B12D (R) |
* | B12E (R-1) |
* | B21D (R) |
* | B21E (R-1) |
* | B22D (R) |
* | B22E (R-1) |
* | CBBCSD RWORK |
* |------------------|
*
IF( INFO .EQ. 0 ) THEN
IPHI = 2
IB11D = IPHI + MAX( 1, R-1 )
IB11E = IB11D + MAX( 1, R )
IB12D = IB11E + MAX( 1, R - 1 )
IB12E = IB12D + MAX( 1, R )
IB21D = IB12E + MAX( 1, R - 1 )
IB21E = IB21D + MAX( 1, R )
IB22D = IB21E + MAX( 1, R - 1 )
IB22E = IB22D + MAX( 1, R )
IBBCSD = IB22E + MAX( 1, R - 1 )
ITAUP1 = 2
ITAUP2 = ITAUP1 + MAX( 1, P )
ITAUQ1 = ITAUP2 + MAX( 1, M-P )
IORBDB = ITAUQ1 + MAX( 1, Q )
IORGQR = ITAUQ1 + MAX( 1, Q )
IORGLQ = ITAUQ1 + MAX( 1, Q )
IF( R .EQ. Q ) THEN
CALL CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
$ 0, 0, WORK, -1, CHILDINFO )
LORBDB = INT( WORK(1) )
IF( P .GE. M-P ) THEN
CALL CUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, P )
LORGQROPT = INT( WORK(1) )
ELSE
CALL CUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, M-P )
LORGQROPT = INT( WORK(1) )
END IF
CALL CUNGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T,
$ 0, WORK(1), -1, CHILDINFO )
LORGLQMIN = MAX( 1, Q-1 )
LORGLQOPT = INT( WORK(1) )
CALL CBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
$ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0,
$ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO )
LBBCSD = INT( RWORK(1) )
ELSE IF( R .EQ. P ) THEN
CALL CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
$ 0, 0, WORK(1), -1, CHILDINFO )
LORBDB = INT( WORK(1) )
IF( P-1 .GE. M-P ) THEN
CALL CUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1),
$ -1, CHILDINFO )
LORGQRMIN = MAX( 1, P-1 )
LORGQROPT = INT( WORK(1) )
ELSE
CALL CUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, M-P )
LORGQROPT = INT( WORK(1) )
END IF
CALL CUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
$ CHILDINFO )
LORGLQMIN = MAX( 1, Q )
LORGLQOPT = INT( WORK(1) )
CALL CBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
$ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0,
$ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO )
LBBCSD = INT( RWORK(1) )
ELSE IF( R .EQ. M-P ) THEN
CALL CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
$ 0, 0, WORK(1), -1, CHILDINFO )
LORBDB = INT( WORK(1) )
IF( P .GE. M-P-1 ) THEN
CALL CUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, P )
LORGQROPT = INT( WORK(1) )
ELSE
CALL CUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0,
$ WORK(1), -1, CHILDINFO )
LORGQRMIN = MAX( 1, M-P-1 )
LORGQROPT = INT( WORK(1) )
END IF
CALL CUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
$ CHILDINFO )
LORGLQMIN = MAX( 1, Q )
LORGLQOPT = INT( WORK(1) )
CALL CBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
$ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1,
$ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1,
$ CHILDINFO )
LBBCSD = INT( RWORK(1) )
ELSE
CALL CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
$ 0, 0, 0, WORK(1), -1, CHILDINFO )
LORBDB = M + INT( WORK(1) )
IF( P .GE. M-P ) THEN
CALL CUNGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, P )
LORGQROPT = INT( WORK(1) )
ELSE
CALL CUNGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, M-P )
LORGQROPT = INT( WORK(1) )
END IF
CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1,
$ CHILDINFO )
LORGLQMIN = MAX( 1, Q )
LORGLQOPT = INT( WORK(1) )
CALL CBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
$ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T,
$ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1,
$ CHILDINFO )
LBBCSD = INT( RWORK(1) )
END IF
LRWORKMIN = IBBCSD+LBBCSD-1
LRWORKOPT = LRWORKMIN
RWORK(1) = LRWORKOPT
LWORKMIN = MAX( IORBDB+LORBDB-1,
$ IORGQR+LORGQRMIN-1,
$ IORGLQ+LORGLQMIN-1 )
LWORKOPT = MAX( IORBDB+LORBDB-1,
$ IORGQR+LORGQROPT-1,
$ IORGLQ+LORGLQOPT-1 )
WORK(1) = LWORKOPT
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
END IF
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'CUNCSD2BY1', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
LORGQR = LWORK-IORGQR+1
LORGLQ = LWORK-IORGLQ+1
*
* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
* in which R = MIN(P,M-P,Q,M-Q)
*
IF( R .EQ. Q ) THEN
*
* Case 1: R = Q
*
* Simultaneously bidiagonalize X11 and X21
*
CALL CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
$ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
$ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
*
* Accumulate Householder reflectors
*
IF( WANTU1 .AND. P .GT. 0 ) THEN
CALL CLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
CALL CUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
$ LORGQR, CHILDINFO )
END IF
IF( WANTU2 .AND. M-P .GT. 0 ) THEN
CALL CLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
CALL CUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
$ WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTV1T .AND. Q .GT. 0 ) THEN
V1T(1,1) = ONE
DO J = 2, Q
V1T(1,J) = ZERO
V1T(J,1) = ZERO
END DO
CALL CLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
$ LDV1T )
CALL CUNGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
$ WORK(IORGLQ), LORGLQ, CHILDINFO )
END IF
*
* Simultaneously diagonalize X11 and X21.
*
CALL CBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
$ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1,
$ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
$ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
$ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
$ CHILDINFO )
*
* Permute rows and columns to place zero submatrices in
* preferred positions
*
IF( Q .GT. 0 .AND. WANTU2 ) THEN
DO I = 1, Q
IWORK(I) = M - P - Q + I
END DO
DO I = Q + 1, M - P
IWORK(I) = I - Q
END DO
CALL CLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
END IF
ELSE IF( R .EQ. P ) THEN
*
* Case 2: R = P
*
* Simultaneously bidiagonalize X11 and X21
*
CALL CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
$ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
$ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
*
* Accumulate Householder reflectors
*
IF( WANTU1 .AND. P .GT. 0 ) THEN
U1(1,1) = ONE
DO J = 2, P
U1(1,J) = ZERO
U1(J,1) = ZERO
END DO
CALL CLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
CALL CUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
$ WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTU2 .AND. M-P .GT. 0 ) THEN
CALL CLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
CALL CUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
$ WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTV1T .AND. Q .GT. 0 ) THEN
CALL CLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
CALL CUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
$ WORK(IORGLQ), LORGLQ, CHILDINFO )
END IF
*
* Simultaneously diagonalize X11 and X21.
*
CALL CBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
$ RWORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2,
$ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
$ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
$ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
$ CHILDINFO )
*
* Permute rows and columns to place identity submatrices in
* preferred positions
*
IF( Q .GT. 0 .AND. WANTU2 ) THEN
DO I = 1, Q
IWORK(I) = M - P - Q + I
END DO
DO I = Q + 1, M - P
IWORK(I) = I - Q
END DO
CALL CLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
END IF
ELSE IF( R .EQ. M-P ) THEN
*
* Case 3: R = M-P
*
* Simultaneously bidiagonalize X11 and X21
*
CALL CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
$ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
$ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
*
* Accumulate Householder reflectors
*
IF( WANTU1 .AND. P .GT. 0 ) THEN
CALL CLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
CALL CUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
$ LORGQR, CHILDINFO )
END IF
IF( WANTU2 .AND. M-P .GT. 0 ) THEN
U2(1,1) = ONE
DO J = 2, M-P
U2(1,J) = ZERO
U2(J,1) = ZERO
END DO
CALL CLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
$ LDU2 )
CALL CUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
$ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTV1T .AND. Q .GT. 0 ) THEN
CALL CLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
CALL CUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
$ WORK(IORGLQ), LORGLQ, CHILDINFO )
END IF
*
* Simultaneously diagonalize X11 and X21.
*
CALL CBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
$ THETA, RWORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2,
$ U1, LDU1, RWORK(IB11D), RWORK(IB11E),
$ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D),
$ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E),
$ RWORK(IBBCSD), LBBCSD, CHILDINFO )
*
* Permute rows and columns to place identity submatrices in
* preferred positions
*
IF( Q .GT. R ) THEN
DO I = 1, R
IWORK(I) = Q - R + I
END DO
DO I = R + 1, Q
IWORK(I) = I - R
END DO
IF( WANTU1 ) THEN
CALL CLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
END IF
IF( WANTV1T ) THEN
CALL CLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
END IF
END IF
ELSE
*
* Case 4: R = M-Q
*
* Simultaneously bidiagonalize X11 and X21
*
CALL CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
$ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
$ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
$ LORBDB-M, CHILDINFO )
*
* Accumulate Householder reflectors
*
IF( WANTU1 .AND. P .GT. 0 ) THEN
CALL CCOPY( P, WORK(IORBDB), 1, U1, 1 )
DO J = 2, P
U1(1,J) = ZERO
END DO
CALL CLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
$ LDU1 )
CALL CUNGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
$ WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTU2 .AND. M-P .GT. 0 ) THEN
CALL CCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
DO J = 2, M-P
U2(1,J) = ZERO
END DO
CALL CLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
$ LDU2 )
CALL CUNGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
$ WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTV1T .AND. Q .GT. 0 ) THEN
CALL CLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
CALL CLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
$ V1T(M-Q+1,M-Q+1), LDV1T )
CALL CLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
$ V1T(P+1,P+1), LDV1T )
CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
$ WORK(IORGLQ), LORGLQ, CHILDINFO )
END IF
*
* Simultaneously diagonalize X11 and X21.
*
CALL CBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
$ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T,
$ LDV1T, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
$ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
$ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
$ CHILDINFO )
*
* Permute rows and columns to place identity submatrices in
* preferred positions
*
IF( P .GT. R ) THEN
DO I = 1, R
IWORK(I) = P - R + I
END DO
DO I = R + 1, P
IWORK(I) = I - R
END DO
IF( WANTU1 ) THEN
CALL CLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
END IF
IF( WANTV1T ) THEN
CALL CLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
END IF
END IF
END IF
*
RETURN
*
* End of CUNCSD2BY1
*
END

31
lapack-netlib/SRC/dbbcsd.f
View File

@ -322,7 +322,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@ -332,10 +332,10 @@
$ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E,
$ B22D, B22E, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS
@ -358,8 +358,8 @@
PARAMETER ( HUNDRED = 100.0D0, MEIGHTH = -0.125D0,
$ ONE = 1.0D0, PIOVER2 = 1.57079632679489662D0,
$ TEN = 10.0D0, ZERO = 0.0D0 )
DOUBLE PRECISION NEGONECOMPLEX
PARAMETER ( NEGONECOMPLEX = -1.0D0 )
DOUBLE PRECISION NEGONE
PARAMETER ( NEGONE = -1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL COLMAJOR, LQUERY, RESTART11, RESTART12,
@ -477,7 +477,10 @@
* Initial deflation
*
IMAX = Q
DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) )
DO WHILE( IMAX .GT. 1 )
IF( PHI(IMAX-1) .NE. ZERO ) THEN
EXIT
END IF
IMAX = IMAX - 1
END DO
IMIN = IMAX - 1
@ -939,9 +942,9 @@
B21D(IMAX) = -B21D(IMAX)
IF( WANTV1T ) THEN
IF( COLMAJOR ) THEN
CALL DSCAL( Q, NEGONECOMPLEX, V1T(IMAX,1), LDV1T )
CALL DSCAL( Q, NEGONE, V1T(IMAX,1), LDV1T )
ELSE
CALL DSCAL( Q, NEGONECOMPLEX, V1T(1,IMAX), 1 )
CALL DSCAL( Q, NEGONE, V1T(1,IMAX), 1 )
END IF
END IF
END IF
@ -962,9 +965,9 @@
B12D(IMAX) = -B12D(IMAX)
IF( WANTU1 ) THEN
IF( COLMAJOR ) THEN
CALL DSCAL( P, NEGONECOMPLEX, U1(1,IMAX), 1 )
CALL DSCAL( P, NEGONE, U1(1,IMAX), 1 )
ELSE
CALL DSCAL( P, NEGONECOMPLEX, U1(IMAX,1), LDU1 )
CALL DSCAL( P, NEGONE, U1(IMAX,1), LDU1 )
END IF
END IF
END IF
@ -972,9 +975,9 @@
B22D(IMAX) = -B22D(IMAX)
IF( WANTU2 ) THEN
IF( COLMAJOR ) THEN
CALL DSCAL( M-P, NEGONECOMPLEX, U2(1,IMAX), 1 )
CALL DSCAL( M-P, NEGONE, U2(1,IMAX), 1 )
ELSE
CALL DSCAL( M-P, NEGONECOMPLEX, U2(IMAX,1), LDU2 )
CALL DSCAL( M-P, NEGONE, U2(IMAX,1), LDU2 )
END IF
END IF
END IF
@ -984,9 +987,9 @@
IF( B12D(IMAX)+B22D(IMAX) .LT. 0 ) THEN
IF( WANTV2T ) THEN
IF( COLMAJOR ) THEN
CALL DSCAL( M-Q, NEGONECOMPLEX, V2T(IMAX,1), LDV2T )
CALL DSCAL( M-Q, NEGONE, V2T(IMAX,1), LDV2T )
ELSE
CALL DSCAL( M-Q, NEGONECOMPLEX, V2T(1,IMAX), 1 )
CALL DSCAL( M-Q, NEGONE, V2T(1,IMAX), 1 )
END IF
END IF
END IF

21
lapack-netlib/SRC/dgebal.f
View File

@ -121,7 +121,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
@ -160,10 +160,10 @@
* =====================================================================
SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOB
@ -192,8 +192,8 @@
* .. External Functions ..
LOGICAL DISNAN, LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH
DOUBLE PRECISION DLAMCH, DNRM2
EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSWAP, XERBLA
@ -312,19 +312,14 @@
SFMAX1 = ONE / SFMIN1
SFMIN2 = SFMIN1*SCLFAC
SFMAX2 = ONE / SFMIN2
*
140 CONTINUE
NOCONV = .FALSE.
*
DO 200 I = K, L
C = ZERO
R = ZERO
*
DO 150 J = K, L
IF( J.EQ.I )
$ GO TO 150
C = C + ABS( A( J, I ) )
R = R + ABS( A( I, J ) )
150 CONTINUE
C = DNRM2( L-K+1, A( K, I ), 1 )
R = DNRM2( L-K+1, A( I, K ), LDA )
ICA = IDAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = IDAMAX( N-K+1, A( I, K ), LDA )

8
lapack-netlib/SRC/dgemqrt.f
View File

@ -160,7 +160,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
@ -168,10 +168,10 @@
SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@ -225,7 +225,7 @@
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN
INFO = -5
ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN
INFO = -6
ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
INFO = -8

8
lapack-netlib/SRC/dgeqrt.f
View File

@ -108,7 +108,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
@ -141,10 +141,10 @@
* =====================================================================
SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDT, M, N, NB
@ -173,7 +173,7 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN
ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5

9
lapack-netlib/SRC/dgesdd.f
View File

@ -175,8 +175,7 @@
*> LWORK >= 3*min(M,N) +
*> max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
*> If JOBZ = 'S' or 'A'
*> LWORK >= 3*min(M,N) +
*> max(max(M,N),4*min(M,N)*min(M,N)+3*min(M,N)+max(M,N)).
*> LWORK >= min(M,N)*(6+4*min(M,N))+max(M,N)
*> For good performance, LWORK should generally be larger.
*> If LWORK = -1 but other input arguments are legal, WORK(1)
*> returns the optimal LWORK.
@ -203,7 +202,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup doubleGEsing
*
@ -217,10 +216,10 @@
SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
$ LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.4.2) --
* -- LAPACK driver routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBZ

11
lapack-netlib/SRC/dgetc2.f
View File

@ -98,7 +98,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup doubleGEauxiliary
*
@ -111,10 +111,10 @@
* =====================================================================
SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
@ -203,6 +203,11 @@
INFO = N
A( N, N ) = SMIN
END IF
*
* Set last pivots to N
*
IPIV( N ) = N
JPIV( N ) = N
*
RETURN
*

20
lapack-netlib/SRC/dhgeqz.f
View File

@ -282,7 +282,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
@ -304,10 +304,10 @@
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
$ LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ, JOB
@ -739,9 +739,9 @@
* Exceptional shift. Chosen for no particularly good reason.
* (Single shift only.)
*
IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT.
IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST, ILAST-1 ) ).LT.
$ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN
ESHIFT = ESHIFT + H( ILAST, ILAST-1 ) /
ESHIFT = H( ILAST, ILAST-1 ) /
$ T( ILAST-1, ILAST-1 )
ELSE
ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) )
@ -759,6 +759,16 @@
$ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1,
$ S2, WR, WR2, WI )
*
IF ( ABS( (WR/S1)*T( ILAST, ILAST ) - H( ILAST, ILAST ) )
$ .GT. ABS( (WR2/S2)*T( ILAST, ILAST )
$ - H( ILAST, ILAST ) ) ) THEN
TEMP = WR
WR = WR2
WR2 = TEMP
TEMP = S1
S1 = S2
S2 = TEMP
END IF
TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) )
IF( WI.NE.ZERO )
$ GO TO 200

16
lapack-netlib/SRC/dhsein.f
View File

@ -108,6 +108,7 @@
*> \verbatim
*> H is DOUBLE PRECISION array, dimension (LDH,N)
*> The upper Hessenberg matrix H.
*> If a NaN is detected in H, the routine will return with INFO=-6.
*> \endverbatim
*>
*> \param[in] LDH
@ -243,7 +244,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@ -262,10 +263,10 @@
$ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
$ IFAILR, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER EIGSRC, INITV, SIDE
@ -291,9 +292,9 @@
$ WKR
* ..
* .. External Functions ..
LOGICAL LSAME
LOGICAL LSAME, DISNAN
DOUBLE PRECISION DLAMCH, DLANHS
EXTERNAL LSAME, DLAMCH, DLANHS
EXTERNAL LSAME, DLAMCH, DLANHS, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL DLAEIN, XERBLA
@ -423,7 +424,10 @@
* has not ben computed before.
*
HNORM = DLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
IF( HNORM.GT.ZERO ) THEN
IF( DISNAN( HNORM ) ) THEN
INFO = -6
RETURN
ELSE IF( HNORM.GT.ZERO ) THEN
EPS3 = HNORM*ULP
ELSE
EPS3 = SMLNUM

159
lapack-netlib/SRC/dladiv.f
View File

@ -36,8 +36,9 @@
*> p + i*q = ---------
*> c + i*d
*>
*> The algorithm is due to Robert L. Smith and can be found
*> in D. Knuth, The art of Computer Programming, Vol.2, p.195
*> The algorithm is due to Michael Baudin and Robert L. Smith
*> and can be found in the paper
*> "A Robust Complex Division in Scilab"
*> \endverbatim
*
* Arguments:
@ -83,17 +84,17 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date January 2013
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* January 2013
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, D, P, Q
@ -101,28 +102,152 @@
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION BS
PARAMETER ( BS = 2.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
*
* .. Local Scalars ..
DOUBLE PRECISION E, F
DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLADIV1
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
IF( ABS( D ).LT.ABS( C ) ) THEN
E = D / C
F = C + D*E
P = ( A+B*E ) / F
Q = ( B-A*E ) / F
ELSE
E = C / D
F = D + C*E
P = ( B+A*E ) / F
Q = ( -A+B*E ) / F
AA = A
BB = B
CC = C
DD = D
AB = MAX( ABS(A), ABS(B) )
CD = MAX( ABS(C), ABS(D) )
S = 1.0D0
OV = DLAMCH( 'Overflow threshold' )
UN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Epsilon' )
BE = BS / (EPS*EPS)
IF( AB >= HALF*OV ) THEN
AA = HALF * AA
BB = HALF * BB
S = TWO * S
END IF
IF( CD >= HALF*OV ) THEN
CC = HALF * CC
DD = HALF * DD
S = HALF * S
END IF
IF( AB <= UN*BS/EPS ) THEN
AA = AA * BE
BB = BB * BE
S = S / BE
END IF
IF( CD <= UN*BS/EPS ) THEN
CC = CC * BE
DD = DD * BE
S = S * BE
END IF
IF( ABS( D ).LE.ABS( C ) ) THEN
CALL DLADIV1(AA, BB, CC, DD, P, Q)
ELSE
CALL DLADIV1(BB, AA, DD, CC, P, Q)
Q = -Q
END IF
P = P * S
Q = Q * S
*
RETURN
*
* End of DLADIV
*
END
SUBROUTINE DLADIV1( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* January 2013
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, D, P, Q
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
*
* .. Local Scalars ..
DOUBLE PRECISION R, T
* ..
* .. External Functions ..
DOUBLE PRECISION DLADIV2
EXTERNAL DLADIV2
* ..
* .. Executable Statements ..
*
R = D / C
T = ONE / (C + D * R)
P = DLADIV2(A, B, C, D, R, T)
A = -A
Q = DLADIV2(B, A, C, D, R, T)
*
RETURN
*
* End of DLADIV1
*
END
DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T )
*
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* January 2013
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, D, R, T
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
*
* .. Local Scalars ..
DOUBLE PRECISION BR
* ..
* .. Executable Statements ..
*
IF( R.NE.ZERO ) THEN
BR = B * R
if( BR.NE.ZERO ) THEN
DLADIV2 = (A + BR) * T
ELSE
DLADIV2 = A * T + (B * T) * R
END IF
ELSE
DLADIV2 = (A + D * (B / C)) * T
END IF
*
RETURN
*
* End of DLADIV12
*
END

8
lapack-netlib/SRC/dlaqp2.f
View File

@ -122,7 +122,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup doubleOTHERauxiliary
*
@ -149,10 +149,10 @@
SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
INTEGER LDA, M, N, OFFSET
@ -217,7 +217,7 @@
CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
END IF
*
IF( I.LE.N ) THEN
IF( I.LT.N ) THEN
*
* Apply H(i)**T to A(offset+i:m,i+1:n) from the left.
*

264
lapack-netlib/SRC/dlarfb.f
View File

@ -159,7 +159,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date June 2013
*
*> \ingroup doubleOTHERauxiliary
*
@ -195,10 +195,10 @@
SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* June 2013
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
@ -217,12 +217,11 @@
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J, LASTV, LASTC, lastv2
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILADLR, ILADLC
EXTERNAL LSAME, ILADLR, ILADLC
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DTRMM
@ -252,58 +251,53 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILADLR( M, K, V, LDV ) )
LASTC = ILADLC( LASTV, N, C, LDC )
*
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
*
* W := C1**T
*
DO 10 J = 1, K
CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**T * V2
*
CALL DGEMM( 'Transpose', 'No transpose',
$ LASTC, K, LASTV-K,
CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
$ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**T
*
IF( LASTV.GT.K ) THEN
IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTV-K, LASTC, K,
CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**T
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
$ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 30 J = 1, K
DO 20 I = 1, LASTC
DO 20 I = 1, N
C( J, I ) = C( J, I ) - WORK( I, J )
20 CONTINUE
30 CONTINUE
@ -311,58 +305,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
*
LASTV = MAX( K, ILADLR( N, K, V, LDV ) )
LASTC = ILADLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-K,
CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**T
*
IF( LASTV.GT.K ) THEN
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, LASTV-K, K,
CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**T
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
$ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, LASTC
DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
@ -378,36 +367,31 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
*
LASTC = ILADLC( M, N, C, LDC )
*
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
*
* W := C2**T
*
DO 70 J = 1, K
CALL DCOPY( LASTC, C( M-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( M-K+1, 1 ), LDV,
$ WORK, LDWORK )
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**T * V1
*
CALL DGEMM( 'Transpose', 'No transpose',
$ LASTC, K, M-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**T
*
@ -415,21 +399,19 @@
*
* C1 := C1 - V1 * W**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2**T
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( M-K+1, 1 ), LDV,
$ WORK, LDWORK )
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
$ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 90 J = 1, K
DO 80 I = 1, LASTC
DO 80 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
80 CONTINUE
90 CONTINUE
@ -437,35 +419,31 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
*
LASTC = ILADLR( M, N, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( N-K+1, 1 ), LDV,
$ WORK, LDWORK )
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, K, N-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**T
*
@ -473,21 +451,19 @@
*
* C1 := C1 - W * V1**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2**T
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( N-K+1, 1 ), LDV,
$ WORK, LDWORK )
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
$ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, LASTC
DO 110 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
110 CONTINUE
120 CONTINUE
@ -505,58 +481,53 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILADLC( K, M, V, LDV ) )
LASTC = ILADLC( LASTV, N, C, LDC )
*
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
*
* W := C1**T
*
DO 130 J = 1, K
CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**T
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
$ ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**T * V2**T
*
CALL DGEMM( 'Transpose', 'Transpose',
$ LASTC, K, LASTV-K,
$ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
$ ONE, WORK, LDWORK )
CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
$ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
$ WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
IF( LASTV.GT.K ) THEN
IF( M.GT.K ) THEN
*
* C2 := C2 - V2**T * W**T
*
CALL DGEMM( 'Transpose', 'Transpose',
$ LASTV-K, LASTC, K,
$ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
$ ONE, C( K+1, 1 ), LDC )
CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
$ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 150 J = 1, K
DO 140 I = 1, LASTC
DO 140 I = 1, N
C( J, I ) = C( J, I ) - WORK( I, J )
140 CONTINUE
150 CONTINUE
@ -564,58 +535,53 @@
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
*
LASTV = MAX( K, ILADLC( K, N, V, LDV ) )
LASTC = ILADLR( M, LASTV, C, LDC )
*
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**T
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
$ ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, K, LASTV-K,
CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
$ ONE, C( 1, K+1 ), LDC )
CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, LASTC
DO 170 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
@ -631,36 +597,31 @@
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
*
LASTC = ILADLC( M, N, C, LDC )
*
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
*
* W := C2**T
*
DO 190 J = 1, K
CALL DCOPY( LASTC, C( M-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**T
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( 1, M-K+1 ), LDV,
$ WORK, LDWORK )
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
$ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**T * V1**T
*
CALL DGEMM( 'Transpose', 'Transpose',
$ LASTC, K, M-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
$ C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
@ -668,58 +629,51 @@
*
* C1 := C1 - V1**T * W**T
*
CALL DGEMM( 'Transpose', 'Transpose',
$ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
$ V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, M-K+1 ), LDV,
$ WORK, LDWORK )
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 210 J = 1, K
DO 200 I = 1, LASTC
DO 200 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
*
LASTC = ILADLR( M, N, C, LDC )
* Form C * H or C * H' where C = ( C1 C2 )
*
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL DCOPY( LASTC, C( 1, N-K+J ), 1,
$ WORK( 1, J ), 1 )
CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**T
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( 1, N-K+1 ), LDV,
$ WORK, LDWORK )
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
$ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, K, N-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
@ -727,21 +681,19 @@
*
* C1 := C1 - W * V1
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, N-K+1 ), LDV,
$ WORK, LDWORK )
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, LASTC
DO 230 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
230 CONTINUE
240 CONTINUE

6
lapack-netlib/SRC/dlasd4.f
View File

@ -140,7 +140,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup auxOTHERauxiliary
*
@ -153,10 +153,10 @@
* =====================================================================
SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
INTEGER I, INFO, N

246
lapack-netlib/SRC/dlasyf.f
View File

@ -1,4 +1,4 @@
*> \brief \b DLASYF computes a partial factorization of a real symmetric matrix, using the diagonal pivoting method.
*> \brief \b DLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
*
* =========== DOCUMENTATION ===========
*
@ -109,16 +109,26 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*> If UPLO = 'U', only the last KB elements of IPIV are set;
*> if UPLO = 'L', only the first KB elements are set.
*>
*> If UPLO = 'U':
*> Only the last KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*>
*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> Only the first KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
@ -149,17 +159,27 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup doubleSYcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*> \endverbatim
*
* =====================================================================
SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@ -237,7 +257,8 @@
ABSAKK = ABS( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
@ -248,7 +269,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@ -293,7 +314,7 @@
*
KP = IMAX
*
* copy column KW-1 of W to column KW
* copy column KW-1 of W to column KW of W
*
CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
ELSE
@ -305,60 +326,118 @@
KSTEP = 2
END IF
END IF
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
*
* KKW is the column of W which corresponds to column KK of A
*
KKW = NB + KK - N
*
* Updated column KP is already stored in column KKW of W
* Interchange rows and columns KP and KK.
* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
* Copy non-updated column KK to column KP of submatrix A
* at step K. No need to copy element into column K
* (or K and K-1 for 2-by-2 pivot) of A, since these columns
* will be later overwritten.
*
A( KP, K ) = A( KK, K )
CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
A( KP, KP ) = A( KK, KK )
CALL DCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
IF( KP.GT.1 )
$ CALL DCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
* Interchange rows KK and KP in last KK columns of A and W
* Interchange rows KK and KP in last K+1 to N columns of A
* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
* later overwritten). Interchange rows KK and KP
* in last KKW to NB columns of W.
*
CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
IF( K.LT.N )
$ CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
$ LDA )
CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column KW of W now holds
* 1-by-1 pivot block D(k): column kw of W now holds
*
* W(k) = U(k)*D(k)
* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
* Store U(k) in column k of A
* Store subdiag. elements of column U(k)
* and 1-by-1 block D(k) in column k of A.
* NOTE: Diagonal element U(k,k) is a UNIT element
* and not stored.
* A(k,k) := D(k,k) = W(k,kw)
* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
R1 = ONE / A( K, K )
CALL DSCAL( K-1, R1, A( 1, K ), 1 )
*
ELSE
*
* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
* hold
* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
* block D(k-1:k,k-1:k) in columns k-1 and k of A.
* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
* block and not stored.
* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
* Store U(k) and U(k-1) in columns k and k-1 of A
* Compose the columns of the inverse of 2-by-2 pivot
* block D in the following way to reduce the number
* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by
* this inverse
*
* D**(-1) = ( d11 d21 )**(-1) =
* ( d21 d22 )
*
* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
* ( (-d21 ) ( d11 ) )
*
* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
*
* * ( ( d22/d21 ) ( -1 ) ) =
* ( ( -1 ) ( d11/d21 ) )
*
* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = 1/d21 * T * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
* = D21 * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / D21
D22 = W( K-1, KW-1 ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
*
* Update elements in columns A(k-1) and A(k) as
* dot products of rows of ( W(kw-1) W(kw) ) and columns
* of D**(-1)
*
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
@ -370,7 +449,9 @@
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
@ -414,20 +495,28 @@
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
* in columns k+1:n
* in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
*
* Undo the interchanges (if any) of rows JJ and JP at each
* step J
*
* (Here, J is a diagonal index)
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
* (Here, J is a diagonal index)
J = J + 1
END IF
* (NOTE: Here, J is used to determine row length. Length N-J+1
* of the rows to swap back doesn't include diagonal element)
J = J + 1
IF( JP.NE.JJ .AND. J.LE.N )
$ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
IF( J.LE.N )
IF( J.LT.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
@ -464,7 +553,8 @@
ABSAKK = ABS( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
@ -475,7 +565,7 @@
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@ -518,7 +608,7 @@
*
KP = IMAX
*
* copy column K+1 of W to column K
* copy column K+1 of W to column K of W
*
CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
ELSE
@ -530,22 +620,36 @@
KSTEP = 2
END IF
END IF
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
* Updated column KP is already stored in column KK of W
* Interchange rows and columns KP and KK.
* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
* Copy non-updated column KK to column KP of submatrix A
* at step K. No need to copy element into column K
* (or K and K+1 for 2-by-2 pivot) of A, since these columns
* will be later overwritten.
*
A( KP, K ) = A( KK, K )
CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
A( KP, KP ) = A( KK, KK )
CALL DCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
$ LDA )
IF( KP.LT.N )
$ CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
*
* Interchange rows KK and KP in first KK columns of A and W
* Interchange rows KK and KP in first K-1 columns of A
* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
* later overwritten). Interchange rows KK and KP
* in first KK columns of W.
*
CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
IF( K.GT.1 )
$ CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
@ -553,17 +657,23 @@
*
* 1-by-1 pivot block D(k): column k of W now holds
*
* W(k) = L(k)*D(k)
* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
* Store L(k) in column k of A
* Store subdiag. elements of column L(k)
* and 1-by-1 block D(k) in column k of A.
* (NOTE: Diagonal element L(k,k) is a UNIT element
* and not stored)
* A(k,k) := D(k,k) = W(k,k)
* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
R1 = ONE / A( K, K )
CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
@ -572,16 +682,52 @@
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
* block D(k:k+1,k:k+1) in columns k and k+1 of A.
* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
* block and not stored)
* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
* Store L(k) and L(k+1) in columns k and k+1 of A
* Compose the columns of the inverse of 2-by-2 pivot
* block D in the following way to reduce the number
* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by
* this inverse
*
* D**(-1) = ( d11 d21 )**(-1) =
* ( d21 d22 )
*
* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
* ( (-d21 ) ( d11 ) )
*
* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
*
* * ( ( d22/d21 ) ( -1 ) ) =
* ( ( -1 ) ( d11/d21 ) )
*
* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = 1/d21 * T * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
* = D21 * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
*
* Update elements in columns A(k) and A(k+1) as
* dot products of rows of ( W(k) W(k+1) ) and columns
* of D**(-1)
*
DO 80 J = K + 2, N
A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
@ -593,7 +739,9 @@
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
@ -638,20 +786,28 @@
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
* in columns 1:k-1
* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
*
* Undo the interchanges (if any) of rows JJ and JP at each
* step J
*
* (Here, J is a diagonal index)
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
* (Here, J is a diagonal index)
J = J - 1
END IF
* (NOTE: Here, J is used to determine row length. Length J
* of the rows to swap back doesn't include diagonal element)
J = J - 1
IF( JP.NE.JJ .AND. J.GE.1 )
$ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
IF( J.GE.1 )
IF( J.GT.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized

892
lapack-netlib/SRC/dlasyf_rook.f Normal file
View File

@ -0,0 +1,892 @@
*> \brief \b DLASYF_ROOK *> DLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASYF_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasyf_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasyf_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasyf_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* .. Scalar Arguments ..
* CHARADLATER UPLO
* INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), W( LDW, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASYF_ROOK computes a partial factorization of a real symmetric
*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal
*> pivoting method. The partial factorization has the form:
*>
*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
*>
*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
*> ( L21 I ) ( 0 A22 ) ( 0 I )
*>
*> where the order of D is at most NB. The actual order is returned in
*> the argument KB, and is either NB or NB-1, or N if N <= NB.
*>
*> DLASYF_ROOK is an auxiliary routine called by DSYTRF_ROOK. It uses
*> blocked code (calling Level 3 BLAS) to update the submatrix
*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> The maximum number of columns of the matrix A that should be
*> factored. NB should be at least 2 to allow for 2-by-2 pivot
*> blocks.
*> \endverbatim
*>
*> \param[out] KB
*> \verbatim
*> KB is INTEGER
*> The number of columns of A that were actually factored.
*> KB is either NB-1 or NB, or N if N <= NB.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit, A contains details of the partial factorization.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> Only the last KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> Only the first KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (LDW,NB)
*> \endverbatim
*>
*> \param[in] LDW
*> \verbatim
*> LDW is INTEGER
*> The leading dimension of the array W. LDW >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup doubleSYcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE DLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW,
$ INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), W( LDW, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK,
$ KW, KKW, KP, KSTEP, P, II
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
$ DTEMP, R1, ROWMAX, T, SFMIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
* Compute machine safe minimum
*
SFMIN = DLAMCH( 'S' )
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Factorize the trailing columns of A using the upper triangle
* of A and working backwards, and compute the matrix W = U12*D
* for use in updating A11
*
* K is the main loop index, decreasing from N in steps of 1 or 2
*
K = N
10 CONTINUE
*
* KW is the column of W which corresponds to column K of A
*
KW = NB + K - N
*
* Exit from loop
*
IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
$ GO TO 30
*
KSTEP = 1
P = K
*
* Copy column K of A to column KW of W and update it
*
CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
IF( K.LT.N )
$ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
$ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
COLMAX = ABS( W( IMAX, KW ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
ELSE
*
* ============================================================
*
* Test for interchange
*
* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
* (used to handle NaN and Inf)
*
IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
ELSE
*
DONE = .FALSE.
*
* Loop until pivot found
*
12 CONTINUE
*
* Begin pivot search loop body
*
*
* Copy column IMAX to column KW-1 of W and update it
*
CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
$ W( IMAX+1, KW-1 ), 1 )
*
IF( K.LT.N )
$ CALL DGEMV( 'No transpose', K, N-K, -ONE,
$ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
$ ONE, W( 1, KW-1 ), 1 )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine both ROWMAX and JMAX.
*
IF( IMAX.NE.K ) THEN
JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ),
$ 1 )
ROWMAX = ABS( W( JMAX, KW-1 ) )
ELSE
ROWMAX = ZERO
END IF
*
IF( IMAX.GT.1 ) THEN
ITEMP = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 )
DTEMP = ABS( W( ITEMP, KW-1 ) )
IF( DTEMP.GT.ROWMAX ) THEN
ROWMAX = DTEMP
JMAX = ITEMP
END IF
END IF
*
* Equivalent to testing for
* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
* (used to handle NaN and Inf)
*
IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) )
$ THEN
*
* interchange rows and columns K and IMAX,
* use 1-by-1 pivot block
*
KP = IMAX
*
* copy column KW-1 of W to column KW of W
*
CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
*
DONE = .TRUE.
*
* Equivalent to testing for ROWMAX.EQ.COLMAX,
* (used to handle NaN and Inf)
*
ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
$ THEN
*
* interchange rows and columns K-1 and IMAX,
* use 2-by-2 pivot block
*
KP = IMAX
KSTEP = 2
DONE = .TRUE.
ELSE
*
* Pivot not found: set params and repeat
*
P = IMAX
COLMAX = ROWMAX
IMAX = JMAX
*
* Copy updated JMAXth (next IMAXth) column to Kth of W
*
CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
*
END IF
*
* End pivot search loop body
*
IF( .NOT. DONE ) GOTO 12
*
END IF
*
* ============================================================
*
KK = K - KSTEP + 1
*
* KKW is the column of W which corresponds to column KK of A
*
KKW = NB + KK - N
*
IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
*
* Copy non-updated column K to column P
*
CALL DCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA )
CALL DCOPY( P, A( 1, K ), 1, A( 1, P ), 1 )
*
* Interchange rows K and P in last N-K+1 columns of A
* and last N-K+2 columns of W
*
CALL DSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA )
CALL DSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW )
END IF
*
* Updated column KP is already stored in column KKW of W
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
*
A( KP, K ) = A( KK, K )
CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
*
* Interchange rows KK and KP in last N-KK+1 columns
* of A and W
*
CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column KW of W now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Store U(k) in column k of A
*
CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
IF( K.GT.1 ) THEN
IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
R1 = ONE / A( K, K )
CALL DSCAL( K-1, R1, A( 1, K ), 1 )
ELSE IF( A( K, K ).NE.ZERO ) THEN
DO 14 II = 1, K - 1
A( II, K ) = A( II, K ) / A( K, K )
14 CONTINUE
END IF
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
* hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
IF( K.GT.2 ) THEN
*
* Store U(k) and U(k-1) in columns k and k-1 of A
*
D12 = W( K-1, KW )
D11 = W( K, KW ) / D12
D22 = W( K-1, KW-1 ) / D12
T = ONE / ( D11*D22-ONE )
DO 20 J = 1, K - 2
A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) /
$ D12 )
A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
$ D12 )
20 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -P
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
30 CONTINUE
*
* Update the upper triangle of A11 (= A(1:k,1:k)) as
*
* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
*
* computing blocks of NB columns at a time
*
DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
JB = MIN( NB, K-J+1 )
*
* Update the upper triangle of the diagonal block
*
DO 40 JJ = J, J + JB - 1
CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
$ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
$ A( J, JJ ), 1 )
40 CONTINUE
*
* Update the rectangular superdiagonal block
*
IF( J.GE.2 )
$ CALL DGEMM( 'No transpose', 'Transpose', J-1, JB,
$ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
$ ONE, A( 1, J ), LDA )
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
* in columns k+1:n
*
J = K + 1
60 CONTINUE
*
KSTEP = 1
JP1 = 1
JJ = J
JP2 = IPIV( J )
IF( JP2.LT.0 ) THEN
JP2 = -JP2
J = J + 1
JP1 = -IPIV( J )
KSTEP = 2
END IF
*
J = J + 1
IF( JP2.NE.JJ .AND. J.LE.N )
$ CALL DSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA )
JJ = J - 1
IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
$ CALL DSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA )
IF( J.LE.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
*
KB = N - K
*
ELSE
*
* Factorize the leading columns of A using the lower triangle
* of A and working forwards, and compute the matrix W = L21*D
* for use in updating A22
*
* K is the main loop index, increasing from 1 in steps of 1 or 2
*
K = 1
70 CONTINUE
*
* Exit from loop
*
IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
$ GO TO 90
*
KSTEP = 1
P = K
*
* Copy column K of A to column K of W and update it
*
CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
IF( K.GT.1 )
$ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
$ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 )
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
COLMAX = ABS( W( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
ELSE
*
* ============================================================
*
* Test for interchange
*
* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
* (used to handle NaN and Inf)
*
IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
ELSE
*
DONE = .FALSE.
*
* Loop until pivot found
*
72 CONTINUE
*
* Begin pivot search loop body
*
*
* Copy column IMAX to column K+1 of W and update it
*
CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1,
$ W( IMAX, K+1 ), 1 )
IF( K.GT.1 )
$ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE,
$ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
$ ONE, W( K, K+1 ), 1 )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine both ROWMAX and JMAX.
*
IF( IMAX.NE.K ) THEN
JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 )
ROWMAX = ABS( W( JMAX, K+1 ) )
ELSE
ROWMAX = ZERO
END IF
*
IF( IMAX.LT.N ) THEN
ITEMP = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
DTEMP = ABS( W( ITEMP, K+1 ) )
IF( DTEMP.GT.ROWMAX ) THEN
ROWMAX = DTEMP
JMAX = ITEMP
END IF
END IF
*
* Equivalent to testing for
* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
* (used to handle NaN and Inf)
*
IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) )
$ THEN
*
* interchange rows and columns K and IMAX,
* use 1-by-1 pivot block
*
KP = IMAX
*
* copy column K+1 of W to column K of W
*
CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
*
DONE = .TRUE.
*
* Equivalent to testing for ROWMAX.EQ.COLMAX,
* (used to handle NaN and Inf)
*
ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
$ THEN
*
* interchange rows and columns K+1 and IMAX,
* use 2-by-2 pivot block
*
KP = IMAX
KSTEP = 2
DONE = .TRUE.
ELSE
*
* Pivot not found: set params and repeat
*
P = IMAX
COLMAX = ROWMAX
IMAX = JMAX
*
* Copy updated JMAXth (next IMAXth) column to Kth of W
*
CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
*
END IF
*
* End pivot search loop body
*
IF( .NOT. DONE ) GOTO 72
*
END IF
*
* ============================================================
*
KK = K + KSTEP - 1
*
IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
*
* Copy non-updated column K to column P
*
CALL DCOPY( P-K, A( K, K ), 1, A( P, K ), LDA )
CALL DCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 )
*
* Interchange rows K and P in first K columns of A
* and first K+1 columns of W
*
CALL DSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA )
CALL DSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
END IF
*
* Updated column KP is already stored in column KK of W
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
*
A( KP, K ) = A( KK, K )
CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
*
* Interchange rows KK and KP in first KK columns of A and W
*
CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k of W now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
* Store L(k) in column k of A
*
CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
R1 = ONE / A( K, K )
CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
ELSE IF( A( K, K ).NE.ZERO ) THEN
DO 74 II = K + 1, N
A( II, K ) = A( II, K ) / A( K, K )
74 CONTINUE
END IF
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
IF( K.LT.N-1 ) THEN
*
* Store L(k) and L(k+1) in columns k and k+1 of A
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = ONE / ( D11*D22-ONE )
DO 80 J = K + 2, N
A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
$ D21 )
A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
$ D21 )
80 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -P
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 70
*
90 CONTINUE
*
* Update the lower triangle of A22 (= A(k:n,k:n)) as
*
* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
*
* computing blocks of NB columns at a time
*
DO 110 J = K, N, NB
JB = MIN( NB, N-J+1 )
*
* Update the lower triangle of the diagonal block
*
DO 100 JJ = J, J + JB - 1
CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
$ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
$ A( JJ, JJ ), 1 )
100 CONTINUE
*
* Update the rectangular subdiagonal block
*
IF( J+JB.LE.N )
$ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
$ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
$ ONE, A( J+JB, J ), LDA )
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
* in columns 1:k-1
*
J = K - 1
120 CONTINUE
*
KSTEP = 1
JP1 = 1
JJ = J
JP2 = IPIV( J )
IF( JP2.LT.0 ) THEN
JP2 = -JP2
J = J - 1
JP1 = -IPIV( J )
KSTEP = 2
END IF
*
J = J - 1
IF( JP2.NE.JJ .AND. J.GE.1 )
$ CALL DSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA )
JJ = J + 1
IF( JP1.NE.JJ .AND. KSTEP.EQ.2 )
$ CALL DSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA )
IF( J.GE.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
*
KB = K - 1
*
END IF
RETURN
*
* End of DLASYF_ROOK
*
END

104
lapack-netlib/SRC/dorbdb.f
View File

@ -255,7 +255,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@ -287,10 +287,10 @@
$ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
$ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIGNS, TRANS
@ -415,19 +415,36 @@
THETA(I) = ATAN2( DNRM2( M-P-I+1, X21(I,I), 1 ),
$ DNRM2( P-I+1, X11(I,I), 1 ) )
*
IF( P .GT. I ) THEN
CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
ELSE IF( P .EQ. I ) THEN
CALL DLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
END IF
X11(I,I) = ONE
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
IF ( M-P .GT. I ) THEN
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
$ TAUP2(I) )
ELSE IF ( M-P .EQ. I ) THEN
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, TAUP2(I) )
END IF
X21(I,I) = ONE
*
IF ( Q .GT. I ) THEN
CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I),
$ X11(I,I+1), LDX11, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
CALL DLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I),
$ X12(I,I), LDX12, WORK )
END IF
IF ( Q .GT. I ) THEN
CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
$ X21(I,I+1), LDX21, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
CALL DLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I),
$ X22(I,I), LDX22, WORK )
END IF
*
IF( I .LT. Q ) THEN
CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1),
@ -444,12 +461,24 @@
$ DNRM2( M-Q-I+1, X12(I,I), LDX12 ) )
*
IF( I .LT. Q ) THEN
IF ( Q-I .EQ. 1 ) THEN
CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11,
$ TAUQ1(I) )
ELSE
CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
$ TAUQ1(I) )
END IF
X11(I,I+1) = ONE
END IF
IF ( Q+I-1 .LT. M ) THEN
IF ( M-Q .EQ. I ) THEN
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
$ TAUQ2(I) )
ELSE
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
$ TAUQ2(I) )
END IF
END IF
X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
@ -458,10 +487,14 @@
CALL DLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK )
END IF
IF ( P .GT. I ) THEN
CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
$ X12(I+1,I), LDX12, WORK )
CALL DLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
$ X22(I+1,I), LDX22, WORK )
END IF
IF ( M-P .GT. I ) THEN
CALL DLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
$ TAUQ2(I), X22(I+1,I), LDX22, WORK )
END IF
*
END DO
*
@ -470,12 +503,19 @@
DO I = Q + 1, P
*
CALL DSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), LDX12 )
IF ( I .GE. M-Q ) THEN
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
$ TAUQ2(I) )
ELSE
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
$ TAUQ2(I) )
END IF
X12(I,I) = ONE
*
IF ( P. GT. I ) THEN
CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
$ X12(I+1,I), LDX12, WORK )
END IF
IF( M-P-Q .GE. 1 )
$ CALL DLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
$ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
@ -487,11 +527,18 @@
DO I = 1, M - P - Q
*
CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(Q+I,P+I), LDX22 )
IF ( I .EQ. M-P-Q ) THEN
CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I),
$ LDX22, TAUQ2(P+I) )
ELSE
CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1),
$ LDX22, TAUQ2(P+I) )
END IF
X22(Q+I,P+I) = ONE
IF ( I .LT. M-P-Q ) THEN
CALL DLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22,
$ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK )
END IF
*
END DO
*
@ -521,18 +568,31 @@
*
CALL DLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
X11(I,I) = ONE
IF ( I .EQ. M-P ) THEN
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
$ TAUP2(I) )
ELSE
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
$ TAUP2(I) )
END IF
X21(I,I) = ONE
*
IF ( Q .GT. I ) THEN
CALL DLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
$ X11(I+1,I), LDX11, WORK )
CALL DLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, TAUP1(I),
$ X12(I,I), LDX12, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
CALL DLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11,
$ TAUP1(I), X12(I,I), LDX12, WORK )
END IF
IF ( Q .GT. I ) THEN
CALL DLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I),
$ X21(I+1,I), LDX21, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
CALL DLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
$ TAUP2(I), X22(I,I), LDX22, WORK )
END IF
*
IF( I .LT. Q ) THEN
CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I+1,I), 1 )
@ -548,10 +608,22 @@
$ DNRM2( M-Q-I+1, X12(I,I), 1 ) )
*
IF( I .LT. Q ) THEN
CALL DLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, TAUQ1(I) )
IF ( Q-I .EQ. 1) THEN
CALL DLARFGP( Q-I, X11(I+1,I), X11(I+1,I), 1,
$ TAUQ1(I) )
ELSE
CALL DLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1,
$ TAUQ1(I) )
END IF
X11(I+1,I) = ONE
END IF
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
IF ( M-Q .GT. I ) THEN
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
$ TAUQ2(I) )
ELSE
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1,
$ TAUQ2(I) )
END IF
X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
@ -562,8 +634,10 @@
END IF
CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
$ X12(I,I+1), LDX12, WORK )
IF ( M-P-I .GT. 0 ) THEN
CALL DLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I),
$ X22(I,I+1), LDX22, WORK )
END IF
*
END DO
*
@ -575,8 +649,10 @@
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
X12(I,I) = ONE
*
IF ( P .GT. I ) THEN
CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
$ X12(I,I+1), LDX12, WORK )
END IF
IF( M-P-Q .GE. 1 )
$ CALL DLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, TAUQ2(I),
$ X22(I,Q+1), LDX22, WORK )
@ -588,12 +664,16 @@
DO I = 1, M - P - Q
*
CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 )
IF ( M-P-Q .EQ. I ) THEN
CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), 1,
$ TAUQ2(P+I) )
ELSE
CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
$ TAUQ2(P+I) )
X22(P+I,Q+I) = ONE
*
CALL DLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
$ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK )
END IF
X22(P+I,Q+I) = ONE
*
END DO
*

324
lapack-netlib/SRC/dorbdb1.f Normal file
View File

@ -0,0 +1,324 @@
*> \brief \b DORBDB1
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORBDB1 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb1.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb1.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb1.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
* DOUBLE PRECISION PHI(*), THETA(*)
* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
* $ X11(LDX11,*), X21(LDX21,*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> DORBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
*> matrix X with orthonomal columns:
*>
*> [ B11 ]
*> [ X11 ] [ P1 | ] [ 0 ]
*> [-----] = [---------] [-----] Q1**T .
*> [ X21 ] [ | P2 ] [ B21 ]
*> [ 0 ]
*>
*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
*> M-P, or M-Q. Routines DORBDB2, DORBDB3, and DORBDB4 handle cases in
*> which Q is not the minimum dimension.
*>
*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
*> Householder vectors.
*>
*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
*> angles THETA, PHI.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows X11 plus the number of rows in X21.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is INTEGER
*> The number of rows in X11. 0 <= P <= M.
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is INTEGER
*> The number of columns in X11 and X21. 0 <= Q <=
*> MIN(P,M-P,M-Q).
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
*> On entry, the top block of the matrix X to be reduced. On
*> exit, the columns of tril(X11) specify reflectors for P1 and
*> the rows of triu(X11,1) specify reflectors for Q1.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*> LDX11 is INTEGER
*> The leading dimension of X11. LDX11 >= P.
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
*> On entry, the bottom block of the matrix X to be reduced. On
*> exit, the columns of tril(X21) specify reflectors for P2.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*> LDX21 is INTEGER
*> The leading dimension of X21. LDX21 >= M-P.
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*> THETA is DOUBLE PRECISION array, dimension (Q)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] PHI
*> \verbatim
*> PHI is DOUBLE PRECISION array, dimension (Q-1)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP1
*> \verbatim
*> TAUP1 is DOUBLE PRECISION array, dimension (P)
*> The scalar factors of the elementary reflectors that define
*> P1.
*> \endverbatim
*>
*> \param[out] TAUP2
*> \verbatim
*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
*> The scalar factors of the elementary reflectors that define
*> P2.
*> \endverbatim
*>
*> \param[out] TAUQ1
*> \verbatim
*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
*> The scalar factors of the elementary reflectors that define
*> Q1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= M-Q.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*>
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup doubleOTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
*> in each bidiagonal band is a product of a sine or cosine of a THETA
*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
*>
*> P1, P2, and Q1 are represented as products of elementary reflectors.
*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
*> and DORGLQ.
*> \endverbatim
*
*> \par References:
* ================
*>
*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
DOUBLE PRECISION PHI(*), THETA(*)
DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
$ X11(LDX11,*), X21(LDX21,*)
* ..
*
* ====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
$ LWORKMIN, LWORKOPT
LOGICAL LQUERY
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
EXTERNAL DNRM2
* ..
* .. Intrinsic Function ..
INTRINSIC ATAN2, COS, MAX, SIN, SQRT
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
LQUERY = LWORK .EQ. -1
*
IF( M .LT. 0 ) THEN
INFO = -1
ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN
INFO = -2
ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN
INFO = -3
ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -5
ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -7
END IF
*
* Compute workspace
*
IF( INFO .EQ. 0 ) THEN
ILARF = 2
LLARF = MAX( P-1, M-P-1, Q-1 )
IORBDB5 = 2
LORBDB5 = Q-2
LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
LWORKMIN = LWORKOPT
WORK(1) = LWORKOPT
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'DORBDB1', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Reduce columns 1, ..., Q of X11 and X21
*
DO I = 1, Q
*
CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
THETA(I) = ATAN2( X21(I,I), X11(I,I) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
X11(I,I) = ONE
X21(I,I) = ONE
CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
$ LDX11, WORK(ILARF) )
CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
$ X21(I,I+1), LDX21, WORK(ILARF) )
*
IF( I .LT. Q ) THEN
CALL DROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S )
CALL DLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
S = X21(I,I+1)
X21(I,I+1) = ONE
CALL DLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
$ X11(I+1,I+1), LDX11, WORK(ILARF) )
CALL DLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK(ILARF) )
C = SQRT( DNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1),
$ 1 )**2 + DNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1),
$ 1 )**2 )
PHI(I) = ATAN2( S, C )
CALL DORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
$ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
$ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5,
$ CHILDINFO )
END IF
*
END DO
*
RETURN
*
* End of DORBDB1
*
END

333
lapack-netlib/SRC/dorbdb2.f Normal file
View File

@ -0,0 +1,333 @@
*> \brief \b DORBDB2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORBDB2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
* DOUBLE PRECISION PHI(*), THETA(*)
* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
* $ X11(LDX11,*), X21(LDX21,*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> DORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
*> matrix X with orthonomal columns:
*>
*> [ B11 ]
*> [ X11 ] [ P1 | ] [ 0 ]
*> [-----] = [---------] [-----] Q1**T .
*> [ X21 ] [ | P2 ] [ B21 ]
*> [ 0 ]
*>
*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
*> Q, or M-Q. Routines DORBDB1, DORBDB3, and DORBDB4 handle cases in
*> which P is not the minimum dimension.
*>
*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
*> Householder vectors.
*>
*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
*> angles THETA, PHI.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows X11 plus the number of rows in X21.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is INTEGER
*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is INTEGER
*> The number of columns in X11 and X21. 0 <= Q <= M.
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
*> On entry, the top block of the matrix X to be reduced. On
*> exit, the columns of tril(X11) specify reflectors for P1 and
*> the rows of triu(X11,1) specify reflectors for Q1.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*> LDX11 is INTEGER
*> The leading dimension of X11. LDX11 >= P.
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
*> On entry, the bottom block of the matrix X to be reduced. On
*> exit, the columns of tril(X21) specify reflectors for P2.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*> LDX21 is INTEGER
*> The leading dimension of X21. LDX21 >= M-P.
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*> THETA is DOUBLE PRECISION array, dimension (Q)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] PHI
*> \verbatim
*> PHI is DOUBLE PRECISION array, dimension (Q-1)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP1
*> \verbatim
*> TAUP1 is DOUBLE PRECISION array, dimension (P)
*> The scalar factors of the elementary reflectors that define
*> P1.
*> \endverbatim
*>
*> \param[out] TAUP2
*> \verbatim
*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
*> The scalar factors of the elementary reflectors that define
*> P2.
*> \endverbatim
*>
*> \param[out] TAUQ1
*> \verbatim
*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
*> The scalar factors of the elementary reflectors that define
*> Q1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= M-Q.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*>
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup doubleOTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
*> in each bidiagonal band is a product of a sine or cosine of a THETA
*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
*>
*> P1, P2, and Q1 are represented as products of elementary reflectors.
*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
*> and DORGLQ.
*> \endverbatim
*
*> \par References:
* ================
*>
*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
DOUBLE PRECISION PHI(*), THETA(*)
DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
$ X11(LDX11,*), X21(LDX21,*)
* ..
*
* ====================================================================
*
* .. Parameters ..
DOUBLE PRECISION NEGONE, ONE
PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
$ LWORKMIN, LWORKOPT
LOGICAL LQUERY
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
EXTERNAL DNRM2
* ..
* .. Intrinsic Function ..
INTRINSIC ATAN2, COS, MAX, SIN, SQRT
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
LQUERY = LWORK .EQ. -1
*
IF( M .LT. 0 ) THEN
INFO = -1
ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
INFO = -2
ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
INFO = -3
ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -5
ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -7
END IF
*
* Compute workspace
*
IF( INFO .EQ. 0 ) THEN
ILARF = 2
LLARF = MAX( P-1, M-P, Q-1 )
IORBDB5 = 2
LORBDB5 = Q-1
LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
LWORKMIN = LWORKOPT
WORK(1) = LWORKOPT
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'DORBDB2', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Reduce rows 1, ..., P of X11 and X21
*
DO I = 1, P
*
IF( I .GT. 1 ) THEN
CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S )
END IF
CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
C = X11(I,I)
X11(I,I) = ONE
CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X11(I+1,I), LDX11, WORK(ILARF) )
CALL DLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X21(I,I), LDX21, WORK(ILARF) )
S = SQRT( DNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
$ 1 )**2 + DNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 )
THETA(I) = ATAN2( S, C )
*
CALL DORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
$ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
$ WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL DSCAL( P-I, NEGONE, X11(I+1,I), 1 )
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
IF( I .LT. P ) THEN
CALL DLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
PHI(I) = ATAN2( X11(I+1,I), X21(I,I) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
X11(I+1,I) = ONE
CALL DLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I),
$ X11(I+1,I+1), LDX11, WORK(ILARF) )
END IF
X21(I,I) = ONE
CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
$ X21(I,I+1), LDX21, WORK(ILARF) )
*
END DO
*
* Reduce the bottom-right portion of X21 to the identity matrix
*
DO I = P + 1, Q
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
X21(I,I) = ONE
CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
$ X21(I,I+1), LDX21, WORK(ILARF) )
END DO
*
RETURN
*
* End of DORBDB2
*
END

332
lapack-netlib/SRC/dorbdb3.f Normal file
View File

@ -0,0 +1,332 @@
*> \brief \b DORBDB3
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORBDB3 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb3.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb3.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb3.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
* DOUBLE PRECISION PHI(*), THETA(*)
* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
* $ X11(LDX11,*), X21(LDX21,*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> DORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
*> matrix X with orthonomal columns:
*>
*> [ B11 ]
*> [ X11 ] [ P1 | ] [ 0 ]
*> [-----] = [---------] [-----] Q1**T .
*> [ X21 ] [ | P2 ] [ B21 ]
*> [ 0 ]
*>
*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
*> Q, or M-Q. Routines DORBDB1, DORBDB2, and DORBDB4 handle cases in
*> which M-P is not the minimum dimension.
*>
*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
*> Householder vectors.
*>
*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
*> implicitly by angles THETA, PHI.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows X11 plus the number of rows in X21.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is INTEGER
*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is INTEGER
*> The number of columns in X11 and X21. 0 <= Q <= M.
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
*> On entry, the top block of the matrix X to be reduced. On
*> exit, the columns of tril(X11) specify reflectors for P1 and
*> the rows of triu(X11,1) specify reflectors for Q1.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*> LDX11 is INTEGER
*> The leading dimension of X11. LDX11 >= P.
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
*> On entry, the bottom block of the matrix X to be reduced. On
*> exit, the columns of tril(X21) specify reflectors for P2.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*> LDX21 is INTEGER
*> The leading dimension of X21. LDX21 >= M-P.
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*> THETA is DOUBLE PRECISION array, dimension (Q)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] PHI
*> \verbatim
*> PHI is DOUBLE PRECISION array, dimension (Q-1)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP1
*> \verbatim
*> TAUP1 is DOUBLE PRECISION array, dimension (P)
*> The scalar factors of the elementary reflectors that define
*> P1.
*> \endverbatim
*>
*> \param[out] TAUP2
*> \verbatim
*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
*> The scalar factors of the elementary reflectors that define
*> P2.
*> \endverbatim
*>
*> \param[out] TAUQ1
*> \verbatim
*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
*> The scalar factors of the elementary reflectors that define
*> Q1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= M-Q.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup doubleOTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
*> in each bidiagonal band is a product of a sine or cosine of a THETA
*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
*>
*> P1, P2, and Q1 are represented as products of elementary reflectors.
*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
*> and DORGLQ.
*> \endverbatim
*
*> \par References:
* ================
*>
*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
DOUBLE PRECISION PHI(*), THETA(*)
DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
$ X11(LDX11,*), X21(LDX21,*)
* ..
*
* ====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
$ LWORKMIN, LWORKOPT
LOGICAL LQUERY
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
EXTERNAL DNRM2
* ..
* .. Intrinsic Function ..
INTRINSIC ATAN2, COS, MAX, SIN, SQRT
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
LQUERY = LWORK .EQ. -1
*
IF( M .LT. 0 ) THEN
INFO = -1
ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN
INFO = -2
ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN
INFO = -3
ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -5
ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -7
END IF
*
* Compute workspace
*
IF( INFO .EQ. 0 ) THEN
ILARF = 2
LLARF = MAX( P, M-P-1, Q-1 )
IORBDB5 = 2
LORBDB5 = Q-1
LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
LWORKMIN = LWORKOPT
WORK(1) = LWORKOPT
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'DORBDB3', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Reduce rows 1, ..., M-P of X11 and X21
*
DO I = 1, M-P
*
IF( I .GT. 1 ) THEN
CALL DROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S )
END IF
*
CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
S = X21(I,I)
X21(I,I) = ONE
CALL DLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X11(I,I), LDX11, WORK(ILARF) )
CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X21(I+1,I), LDX21, WORK(ILARF) )
C = SQRT( DNRM2( P-I+1, X11(I,I), 1, X11(I,I),
$ 1 )**2 + DNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 )
THETA(I) = ATAN2( S, C )
*
CALL DORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
$ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
$ WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
IF( I .LT. M-P ) THEN
CALL DLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
PHI(I) = ATAN2( X21(I+1,I), X11(I,I) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
X21(I+1,I) = ONE
CALL DLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I),
$ X21(I+1,I+1), LDX21, WORK(ILARF) )
END IF
X11(I,I) = ONE
CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
$ LDX11, WORK(ILARF) )
*
END DO
*
* Reduce the bottom-right portion of X11 to the identity matrix
*
DO I = M-P + 1, Q
CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
X11(I,I) = ONE
CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
$ LDX11, WORK(ILARF) )
END DO
*
RETURN
*
* End of DORBDB3
*
END

378
lapack-netlib/SRC/dorbdb4.f Normal file
View File

@ -0,0 +1,378 @@
*> \brief \b DORBDB4
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORBDB4 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb4.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb4.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb4.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
* DOUBLE PRECISION PHI(*), THETA(*)
* DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
* $ WORK(*), X11(LDX11,*), X21(LDX21,*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> DORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
*> matrix X with orthonomal columns:
*>
*> [ B11 ]
*> [ X11 ] [ P1 | ] [ 0 ]
*> [-----] = [---------] [-----] Q1**T .
*> [ X21 ] [ | P2 ] [ B21 ]
*> [ 0 ]
*>
*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
*> M-P, or Q. Routines DORBDB1, DORBDB2, and DORBDB3 handle cases in
*> which M-Q is not the minimum dimension.
*>
*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
*> Householder vectors.
*>
*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
*> implicitly by angles THETA, PHI.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows X11 plus the number of rows in X21.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is INTEGER
*> The number of rows in X11. 0 <= P <= M.
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is INTEGER
*> The number of columns in X11 and X21. 0 <= Q <= M and
*> M-Q <= min(P,M-P,Q).
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
*> On entry, the top block of the matrix X to be reduced. On
*> exit, the columns of tril(X11) specify reflectors for P1 and
*> the rows of triu(X11,1) specify reflectors for Q1.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*> LDX11 is INTEGER
*> The leading dimension of X11. LDX11 >= P.
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
*> On entry, the bottom block of the matrix X to be reduced. On
*> exit, the columns of tril(X21) specify reflectors for P2.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*> LDX21 is INTEGER
*> The leading dimension of X21. LDX21 >= M-P.
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*> THETA is DOUBLE PRECISION array, dimension (Q)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] PHI
*> \verbatim
*> PHI is DOUBLE PRECISION array, dimension (Q-1)
*> The entries of the bidiagonal blocks B11, B21 are defined by
*> THETA and PHI. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP1
*> \verbatim
*> TAUP1 is DOUBLE PRECISION array, dimension (P)
*> The scalar factors of the elementary reflectors that define
*> P1.
*> \endverbatim
*>
*> \param[out] TAUP2
*> \verbatim
*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
*> The scalar factors of the elementary reflectors that define
*> P2.
*> \endverbatim
*>
*> \param[out] TAUQ1
*> \verbatim
*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
*> The scalar factors of the elementary reflectors that define
*> Q1.
*> \endverbatim
*>
*> \param[out] PHANTOM
*> \verbatim
*> PHANTOM is DOUBLE PRECISION array, dimension (M)
*> The routine computes an M-by-1 column vector Y that is
*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
*> Y(P+1:M), respectively.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= M-Q.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup doubleOTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
*> in each bidiagonal band is a product of a sine or cosine of a THETA
*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
*>
*> P1, P2, and Q1 are represented as products of elementary reflectors.
*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
*> and DORGLQ.
*> \endverbatim
*
*> \par References:
* ================
*>
*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
* ..
* .. Array Arguments ..
DOUBLE PRECISION PHI(*), THETA(*)
DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
$ WORK(*), X11(LDX11,*), X21(LDX21,*)
* ..
*
* ====================================================================
*
* .. Parameters ..
DOUBLE PRECISION NEGONE, ONE, ZERO
PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
$ LORBDB5, LWORKMIN, LWORKOPT
LOGICAL LQUERY
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
EXTERNAL DNRM2
* ..
* .. Intrinsic Function ..
INTRINSIC ATAN2, COS, MAX, SIN, SQRT
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
LQUERY = LWORK .EQ. -1
*
IF( M .LT. 0 ) THEN
INFO = -1
ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN
INFO = -2
ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN
INFO = -3
ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -5
ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -7
END IF
*
* Compute workspace
*
IF( INFO .EQ. 0 ) THEN
ILARF = 2
LLARF = MAX( Q-1, P-1, M-P-1 )
IORBDB5 = 2
LORBDB5 = Q
LWORKOPT = ILARF + LLARF - 1
LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
LWORKMIN = LWORKOPT
WORK(1) = LWORKOPT
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'DORBDB4', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Reduce columns 1, ..., M-Q of X11 and X21
*
DO I = 1, M-Q
*
IF( I .EQ. 1 ) THEN
DO J = 1, M
PHANTOM(J) = ZERO
END DO
CALL DORBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1,
$ X11, LDX11, X21, LDX21, WORK(IORBDB5),
$ LORBDB5, CHILDINFO )
CALL DSCAL( P, NEGONE, PHANTOM(1), 1 )
CALL DLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
CALL DLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
PHANTOM(1) = ONE
PHANTOM(P+1) = ONE
CALL DLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11,
$ WORK(ILARF) )
CALL DLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21,
$ LDX21, WORK(ILARF) )
ELSE
CALL DORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
$ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
$ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL DSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
CALL DLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
CALL DLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
$ TAUP2(I) )
THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
X11(I,I-1) = ONE
X21(I,I-1) = ONE
CALL DLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I),
$ X11(I,I), LDX11, WORK(ILARF) )
CALL DLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I),
$ X21(I,I), LDX21, WORK(ILARF) )
END IF
*
CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
C = X21(I,I)
X21(I,I) = ONE
CALL DLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X11(I+1,I), LDX11, WORK(ILARF) )
CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X21(I+1,I), LDX21, WORK(ILARF) )
IF( I .LT. M-Q ) THEN
S = SQRT( DNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
$ 1 )**2 + DNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I),
$ 1 )**2 )
PHI(I) = ATAN2( S, C )
END IF
*
END DO
*
* Reduce the bottom-right portion of X11 to [ I 0 ]
*
DO I = M - Q + 1, P
CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
X11(I,I) = ONE
CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X11(I+1,I), LDX11, WORK(ILARF) )
CALL DLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X21(M-Q+1,I), LDX21, WORK(ILARF) )
END DO
*
* Reduce the bottom-right portion of X21 to [ 0 I ]
*
DO I = P + 1, Q
CALL DLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
$ TAUQ1(I) )
X21(M-Q+I-P,I) = ONE
CALL DLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
$ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
END DO
*
RETURN
*
* End of DORBDB4
*
END

274
lapack-netlib/SRC/dorbdb5.f Normal file
View File

@ -0,0 +1,274 @@
*> \brief \b DORBDB5
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORBDB5 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb5.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb5.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb5.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
* LDQ2, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
* $ N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> DORBDB5 orthogonalizes the column vector
*> X = [ X1 ]
*> [ X2 ]
*> with respect to the columns of
*> Q = [ Q1 ] .
*> [ Q2 ]
*> The columns of Q must be orthonormal.
*>
*> If the projection is zero according to Kahan's "twice is enough"
*> criterion, then some other vector from the orthogonal complement
*> is returned. This vector is chosen in an arbitrary but deterministic
*> way.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M1
*> \verbatim
*> M1 is INTEGER
*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
*> \endverbatim
*>
*> \param[in] M2
*> \verbatim
*> M2 is INTEGER
*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in Q1 and Q2. 0 <= N.
*> \endverbatim
*>
*> \param[in,out] X1
*> \verbatim
*> X1 is DOUBLE PRECISION array, dimension (M1)
*> On entry, the top part of the vector to be orthogonalized.
*> On exit, the top part of the projected vector.
*> \endverbatim
*>
*> \param[in] INCX1
*> \verbatim
*> INCX1 is INTEGER
*> Increment for entries of X1.
*> \endverbatim
*>
*> \param[in,out] X2
*> \verbatim
*> X2 is DOUBLE PRECISION array, dimension (M2)
*> On entry, the bottom part of the vector to be
*> orthogonalized. On exit, the bottom part of the projected
*> vector.
*> \endverbatim
*>
*> \param[in] INCX2
*> \verbatim
*> INCX2 is INTEGER
*> Increment for entries of X2.
*> \endverbatim
*>
*> \param[in] Q1
*> \verbatim
*> Q1 is DOUBLE PRECISION array, dimension (LDQ1, N)
*> The top part of the orthonormal basis matrix.
*> \endverbatim
*>
*> \param[in] LDQ1
*> \verbatim
*> LDQ1 is INTEGER
*> The leading dimension of Q1. LDQ1 >= M1.
*> \endverbatim
*>
*> \param[in] Q2
*> \verbatim
*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N)
*> The bottom part of the orthonormal basis matrix.
*> \endverbatim
*>
*> \param[in] LDQ2
*> \verbatim
*> LDQ2 is INTEGER
*> The leading dimension of Q2. LDQ2 >= M2.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= N.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
$ LDQ2, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
$ N
* ..
* .. Array Arguments ..
DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER CHILDINFO, I, J
* ..
* .. External Subroutines ..
EXTERNAL DORBDB6, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
EXTERNAL DNRM2
* ..
* .. Intrinsic Function ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
IF( M1 .LT. 0 ) THEN
INFO = -1
ELSE IF( M2 .LT. 0 ) THEN
INFO = -2
ELSE IF( N .LT. 0 ) THEN
INFO = -3
ELSE IF( INCX1 .LT. 1 ) THEN
INFO = -5
ELSE IF( INCX2 .LT. 1 ) THEN
INFO = -7
ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
INFO = -9
ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
INFO = -11
ELSE IF( LWORK .LT. N ) THEN
INFO = -13
END IF
*
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'DORBDB5', -INFO )
RETURN
END IF
*
* Project X onto the orthogonal complement of Q
*
CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2,
$ WORK, LWORK, CHILDINFO )
*
* If the projection is nonzero, then return
*
IF( DNRM2(M1,X1,INCX1) .NE. ZERO
$ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
RETURN
END IF
*
* Project each standard basis vector e_1,...,e_M1 in turn, stopping
* when a nonzero projection is found
*
DO I = 1, M1
DO J = 1, M1
X1(J) = ZERO
END DO
X1(I) = ONE
DO J = 1, M2
X2(J) = ZERO
END DO
CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
$ LDQ2, WORK, LWORK, CHILDINFO )
IF( DNRM2(M1,X1,INCX1) .NE. ZERO
$ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
RETURN
END IF
END DO
*
* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
* stopping when a nonzero projection is found
*
DO I = 1, M2
DO J = 1, M1
X1(J) = ZERO
END DO
DO J = 1, M2
X2(J) = ZERO
END DO
X2(I) = ONE
CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
$ LDQ2, WORK, LWORK, CHILDINFO )
IF( DNRM2(M1,X1,INCX1) .NE. ZERO
$ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
RETURN
END IF
END DO
*
RETURN
*
* End of DORBDB5
*
END

312
lapack-netlib/SRC/dorbdb6.f Normal file
View File

@ -0,0 +1,312 @@
*> \brief \b DORBDB6
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORBDB6 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb6.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb6.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb6.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
* LDQ2, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
* $ N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*>
*> DORBDB6 orthogonalizes the column vector
*> X = [ X1 ]
*> [ X2 ]
*> with respect to the columns of
*> Q = [ Q1 ] .
*> [ Q2 ]
*> The columns of Q must be orthonormal.
*>
*> If the projection is zero according to Kahan's "twice is enough"
*> criterion, then the zero vector is returned.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M1
*> \verbatim
*> M1 is INTEGER
*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
*> \endverbatim
*>
*> \param[in] M2
*> \verbatim
*> M2 is INTEGER
*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in Q1 and Q2. 0 <= N.
*> \endverbatim
*>
*> \param[in,out] X1
*> \verbatim
*> X1 is DOUBLE PRECISION array, dimension (M1)
*> On entry, the top part of the vector to be orthogonalized.
*> On exit, the top part of the projected vector.
*> \endverbatim
*>
*> \param[in] INCX1
*> \verbatim
*> INCX1 is INTEGER
*> Increment for entries of X1.
*> \endverbatim
*>
*> \param[in,out] X2
*> \verbatim
*> X2 is DOUBLE PRECISION array, dimension (M2)
*> On entry, the bottom part of the vector to be
*> orthogonalized. On exit, the bottom part of the projected
*> vector.
*> \endverbatim
*>
*> \param[in] INCX2
*> \verbatim
*> INCX2 is INTEGER
*> Increment for entries of X2.
*> \endverbatim
*>
*> \param[in] Q1
*> \verbatim
*> Q1 is DOUBLE PRECISION array, dimension (LDQ1, N)
*> The top part of the orthonormal basis matrix.
*> \endverbatim
*>
*> \param[in] LDQ1
*> \verbatim
*> LDQ1 is INTEGER
*> The leading dimension of Q1. LDQ1 >= M1.
*> \endverbatim
*>
*> \param[in] Q2
*> \verbatim
*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N)
*> The bottom part of the orthonormal basis matrix.
*> \endverbatim
*>
*> \param[in] LDQ2
*> \verbatim
*> LDQ2 is INTEGER
*> The leading dimension of Q2. LDQ2 >= M2.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= N.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
$ LDQ2, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
$ N
* ..
* .. Array Arguments ..
DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ALPHASQ, REALONE, REALZERO
PARAMETER ( ALPHASQ = 0.01D0, REALONE = 1.0D0,
$ REALZERO = 0.0D0 )
DOUBLE PRECISION NEGONE, ONE, ZERO
PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DLASSQ, XERBLA
* ..
* .. Intrinsic Function ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
IF( M1 .LT. 0 ) THEN
INFO = -1
ELSE IF( M2 .LT. 0 ) THEN
INFO = -2
ELSE IF( N .LT. 0 ) THEN
INFO = -3
ELSE IF( INCX1 .LT. 1 ) THEN
INFO = -5
ELSE IF( INCX2 .LT. 1 ) THEN
INFO = -7
ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
INFO = -9
ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
INFO = -11
ELSE IF( LWORK .LT. N ) THEN
INFO = -13
END IF
*
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'DORBDB6', -INFO )
RETURN
END IF
*
* First, project X onto the orthogonal complement of Q's column
* space
*
SCL1 = REALZERO
SSQ1 = REALONE
CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
SCL2 = REALZERO
SSQ2 = REALONE
CALL DLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
*
IF( M1 .EQ. 0 ) THEN
DO I = 1, N
WORK(I) = ZERO
END DO
ELSE
CALL DGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
$ 1 )
END IF
*
CALL DGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
*
CALL DGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
$ INCX1 )
CALL DGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
$ INCX2 )
*
SCL1 = REALZERO
SSQ1 = REALONE
CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
SCL2 = REALZERO
SSQ2 = REALONE
CALL DLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
*
* If projection is sufficiently large in norm, then stop.
* If projection is zero, then stop.
* Otherwise, project again.
*
IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
RETURN
END IF
*
IF( NORMSQ2 .EQ. ZERO ) THEN
RETURN
END IF
*
NORMSQ1 = NORMSQ2
*
DO I = 1, N
WORK(I) = ZERO
END DO
*
IF( M1 .EQ. 0 ) THEN
DO I = 1, N
WORK(I) = ZERO
END DO
ELSE
CALL DGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
$ 1 )
END IF
*
CALL DGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
*
CALL DGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
$ INCX1 )
CALL DGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
$ INCX2 )
*
SCL1 = REALZERO
SSQ1 = REALONE
CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
SCL2 = REALZERO
SSQ2 = REALONE
CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
*
* If second projection is sufficiently large in norm, then do
* nothing more. Alternatively, if it shrunk significantly, then
* truncate it to zero.
*
IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
DO I = 1, M1
X1(I) = ZERO
END DO
DO I = 1, M2
X2(I) = ZERO
END DO
END IF
*
RETURN
*
* End of DORBDB6
*
END

42
lapack-netlib/SRC/dorcsd.f
View File

@ -289,7 +289,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@ -300,10 +300,10 @@
$ U1, LDU1, U2, LDU2, V1T, LDV1T, V2T,
$ LDV2T, WORK, LWORK, IWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS
@ -368,9 +368,22 @@
INFO = -8
ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
INFO = -9
ELSE IF( ( COLMAJOR .AND. LDX11 .LT. MAX(1,P) ) .OR.
$ ( .NOT.COLMAJOR .AND. LDX11 .LT. MAX(1,Q) ) ) THEN
ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -11
ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN
INFO = -11
ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN
INFO = -13
ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN
INFO = -13
ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -15
ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN
INFO = -15
ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN
INFO = -17
ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN
INFO = -17
ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
INFO = -20
ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN
@ -427,19 +440,19 @@
ITAUQ1 = ITAUP2 + MAX( 1, M - P )
ITAUQ2 = ITAUQ1 + MAX( 1, Q )
IORGQR = ITAUQ2 + MAX( 1, M - Q )
CALL DORGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1,
CALL DORGQR( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1,
$ CHILDINFO )
LORGQRWORKOPT = INT( WORK(1) )
LORGQRWORKMIN = MAX( 1, M - Q )
IORGLQ = ITAUQ2 + MAX( 1, M - Q )
CALL DORGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1,
CALL DORGLQ( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1,
$ CHILDINFO )
LORGLQWORKOPT = INT( WORK(1) )
LORGLQWORKMIN = MAX( 1, M - Q )
IORBDB = ITAUQ2 + MAX( 1, M - Q )
CALL DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ X21, LDX21, X22, LDX22, 0, 0, 0, 0, 0, 0, WORK,
$ -1, CHILDINFO )
$ X21, LDX21, X22, LDX22, THETA, V1T, U1, U2, V1T,
$ V2T, WORK, -1, CHILDINFO )
LORBDBWORKOPT = INT( WORK(1) )
LORBDBWORKMIN = LORBDBWORKOPT
IB11D = ITAUQ2 + MAX( 1, M - Q )
@ -451,9 +464,10 @@
IB22D = IB21E + MAX( 1, Q - 1 )
IB22E = IB22D + MAX( 1, Q )
IBBCSD = IB22E + MAX( 1, Q - 1 )
CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, 0,
$ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, 0,
$ 0, 0, 0, 0, 0, 0, 0, WORK, -1, CHILDINFO )
CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q,
$ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T,
$ LDV2T, U1, U1, U1, U1, U1, U1, U1, U1, WORK, -1,
$ CHILDINFO )
LBBCSDWORKOPT = INT( WORK(1) )
LBBCSDWORKMIN = LBBCSDWORKOPT
LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT,
@ -514,11 +528,15 @@
END IF
IF( WANTV2T .AND. M-Q .GT. 0 ) THEN
CALL DLACPY( 'U', P, M-Q, X12, LDX12, V2T, LDV2T )
IF (M-P .GT. Q) Then
CALL DLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22,
$ V2T(P+1,P+1), LDV2T )
END IF
IF (M .GT. Q) THEN
CALL DORGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2),
$ WORK(IORGLQ), LORGLQWORK, INFO )
END IF
END IF
ELSE
IF( WANTU1 .AND. P .GT. 0 ) THEN
CALL DLACPY( 'U', Q, P, X11, LDX11, U1, LDU1 )

715
lapack-netlib/SRC/dorcsd2by1.f Normal file
View File

@ -0,0 +1,715 @@
*> \brief \b DORCSD2BY1
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORCSD2BY1 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorcsd2by1.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorcsd2by1.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorcsd2by1.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
* LDV1T, WORK, LWORK, IWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBU1, JOBU2, JOBV1T
* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
* $ M, P, Q
* ..
* .. Array Arguments ..
* DOUBLE PRECISION THETA(*)
* DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
* $ X11(LDX11,*), X21(LDX21,*)
* INTEGER IWORK(*)
* ..
*
*
*> \par Purpose:
*> =============
*>
*>\verbatim
*> Purpose:
*> ========
*>
*> DORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
*> orthonormal columns that has been partitioned into a 2-by-1 block
*> structure:
*>
*> [ I 0 0 ]
*> [ 0 C 0 ]
*> [ X11 ] [ U1 | ] [ 0 0 0 ]
*> X = [-----] = [---------] [----------] V1**T .
*> [ X21 ] [ | U2 ] [ 0 0 0 ]
*> [ 0 S 0 ]
*> [ 0 0 I ]
*>
*> X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,
*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
*> which R = MIN(P,M-P,Q,M-Q).
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBU1
*> \verbatim
*> JOBU1 is CHARACTER
*> = 'Y': U1 is computed;
*> otherwise: U1 is not computed.
*> \endverbatim
*>
*> \param[in] JOBU2
*> \verbatim
*> JOBU2 is CHARACTER
*> = 'Y': U2 is computed;
*> otherwise: U2 is not computed.
*> \endverbatim
*>
*> \param[in] JOBV1T
*> \verbatim
*> JOBV1T is CHARACTER
*> = 'Y': V1T is computed;
*> otherwise: V1T is not computed.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows and columns in X.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is INTEGER
*> The number of rows in X11 and X12. 0 <= P <= M.
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is INTEGER
*> The number of columns in X11 and X21. 0 <= Q <= M.
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
*> On entry, part of the orthogonal matrix whose CSD is
*> desired.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*> LDX11 is INTEGER
*> The leading dimension of X11. LDX11 >= MAX(1,P).
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
*> On entry, part of the orthogonal matrix whose CSD is
*> desired.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*> LDX21 is INTEGER
*> The leading dimension of X21. LDX21 >= MAX(1,M-P).
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*> THETA is DOUBLE PRECISION array, dimension (R), in which R =
*> MIN(P,M-P,Q,M-Q).
*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
*> \endverbatim
*>
*> \param[out] U1
*> \verbatim
*> U1 is DOUBLE PRECISION array, dimension (P)
*> If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
*> \endverbatim
*>
*> \param[in] LDU1
*> \verbatim
*> LDU1 is INTEGER
*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
*> MAX(1,P).
*> \endverbatim
*>
*> \param[out] U2
*> \verbatim
*> U2 is DOUBLE PRECISION array, dimension (M-P)
*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
*> matrix U2.
*> \endverbatim
*>
*> \param[in] LDU2
*> \verbatim
*> LDU2 is INTEGER
*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
*> MAX(1,M-P).
*> \endverbatim
*>
*> \param[out] V1T
*> \verbatim
*> V1T is DOUBLE PRECISION array, dimension (Q)
*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
*> matrix V1**T.
*> \endverbatim
*>
*> \param[in] LDV1T
*> \verbatim
*> LDV1T is INTEGER
*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
*> MAX(1,Q).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
*> define the matrix in intermediate bidiagonal-block form
*> remaining after nonconvergence. INFO specifies the number
*> of nonzero PHI's.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> \endverbatim
*>
*> 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.
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> > 0: DBBCSD did not converge. See the description of WORK
*> above for details.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup doubleOTHERcomputational
*
*> \par References:
* ================
*>
*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*> Algorithms, 50(1):33-65, 2009.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
$ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
$ LDV1T, WORK, LWORK, IWORK, INFO )
*
* -- LAPACK computational routine (3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T
INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
$ M, P, Q
* ..
* .. Array Arguments ..
DOUBLE PRECISION THETA(*)
DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
$ X11(LDX11,*), X21(LDX21,*)
INTEGER IWORK(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
$ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
$ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
$ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
$ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
$ LWORKMIN, LWORKOPT, R
LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
* ..
* .. External Subroutines ..
EXTERNAL DBBCSD, DCOPY, DLACPY, DLAPMR, DLAPMT, DORBDB1,
$ DORBDB2, DORBDB3, DORBDB4, DORGLQ, DORGQR,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Function ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
WANTU1 = LSAME( JOBU1, 'Y' )
WANTU2 = LSAME( JOBU2, 'Y' )
WANTV1T = LSAME( JOBV1T, 'Y' )
LQUERY = LWORK .EQ. -1
*
IF( M .LT. 0 ) THEN
INFO = -4
ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
INFO = -5
ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
INFO = -6
ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
INFO = -8
ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
INFO = -10
ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
INFO = -13
ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN
INFO = -15
ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN
INFO = -17
END IF
*
R = MIN( P, M-P, Q, M-Q )
*
* Compute workspace
*
* WORK layout:
* |-------------------------------------------------------|
* | LWORKOPT (1) |
* |-------------------------------------------------------|
* | PHI (MAX(1,R-1)) |
* |-------------------------------------------------------|
* | TAUP1 (MAX(1,P)) | B11D (R) |
* | TAUP2 (MAX(1,M-P)) | B11E (R-1) |
* | TAUQ1 (MAX(1,Q)) | B12D (R) |
* |-----------------------------------------| B12E (R-1) |
* | DORBDB WORK | DORGQR WORK | DORGLQ WORK | B21D (R) |
* | | | | B21E (R-1) |
* | | | | B22D (R) |
* | | | | B22E (R-1) |
* | | | | DBBCSD WORK |
* |-------------------------------------------------------|
*
IF( INFO .EQ. 0 ) THEN
IPHI = 2
IB11D = IPHI + MAX( 1, R-1 )
IB11E = IB11D + MAX( 1, R )
IB12D = IB11E + MAX( 1, R - 1 )
IB12E = IB12D + MAX( 1, R )
IB21D = IB12E + MAX( 1, R - 1 )
IB21E = IB21D + MAX( 1, R )
IB22D = IB21E + MAX( 1, R - 1 )
IB22E = IB22D + MAX( 1, R )
IBBCSD = IB22E + MAX( 1, R - 1 )
ITAUP1 = IPHI + MAX( 1, R-1 )
ITAUP2 = ITAUP1 + MAX( 1, P )
ITAUQ1 = ITAUP2 + MAX( 1, M-P )
IORBDB = ITAUQ1 + MAX( 1, Q )
IORGQR = ITAUQ1 + MAX( 1, Q )
IORGLQ = ITAUQ1 + MAX( 1, Q )
IF( R .EQ. Q ) THEN
CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
$ 0, 0, WORK, -1, CHILDINFO )
LORBDB = INT( WORK(1) )
IF( P .GE. M-P ) THEN
CALL DORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, P )
LORGQROPT = INT( WORK(1) )
ELSE
CALL DORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, M-P )
LORGQROPT = INT( WORK(1) )
END IF
CALL DORGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T,
$ 0, WORK(1), -1, CHILDINFO )
LORGLQMIN = MAX( 1, Q-1 )
LORGLQOPT = INT( WORK(1) )
CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
$ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0,
$ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO )
LBBCSD = INT( WORK(1) )
ELSE IF( R .EQ. P ) THEN
CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
$ 0, 0, WORK(1), -1, CHILDINFO )
LORBDB = INT( WORK(1) )
IF( P-1 .GE. M-P ) THEN
CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1),
$ -1, CHILDINFO )
LORGQRMIN = MAX( 1, P-1 )
LORGQROPT = INT( WORK(1) )
ELSE
CALL DORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, M-P )
LORGQROPT = INT( WORK(1) )
END IF
CALL DORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
$ CHILDINFO )
LORGLQMIN = MAX( 1, Q )
LORGLQOPT = INT( WORK(1) )
CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
$ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0,
$ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO )
LBBCSD = INT( WORK(1) )
ELSE IF( R .EQ. M-P ) THEN
CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
$ 0, 0, WORK(1), -1, CHILDINFO )
LORBDB = INT( WORK(1) )
IF( P .GE. M-P-1 ) THEN
CALL DORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, P )
LORGQROPT = INT( WORK(1) )
ELSE
CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0,
$ WORK(1), -1, CHILDINFO )
LORGQRMIN = MAX( 1, M-P-1 )
LORGQROPT = INT( WORK(1) )
END IF
CALL DORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
$ CHILDINFO )
LORGLQMIN = MAX( 1, Q )
LORGLQOPT = INT( WORK(1) )
CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
$ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1,
$ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1,
$ CHILDINFO )
LBBCSD = INT( WORK(1) )
ELSE
CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
$ 0, 0, 0, WORK(1), -1, CHILDINFO )
LORBDB = M + INT( WORK(1) )
IF( P .GE. M-P ) THEN
CALL DORGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, P )
LORGQROPT = INT( WORK(1) )
ELSE
CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1,
$ CHILDINFO )
LORGQRMIN = MAX( 1, M-P )
LORGQROPT = INT( WORK(1) )
END IF
CALL DORGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1,
$ CHILDINFO )
LORGLQMIN = MAX( 1, Q )
LORGLQOPT = INT( WORK(1) )
CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
$ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T,
$ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1,
$ CHILDINFO )
LBBCSD = INT( WORK(1) )
END IF
LWORKMIN = MAX( IORBDB+LORBDB-1,
$ IORGQR+LORGQRMIN-1,
$ IORGLQ+LORGLQMIN-1,
$ IBBCSD+LBBCSD-1 )
LWORKOPT = MAX( IORBDB+LORBDB-1,
$ IORGQR+LORGQROPT-1,
$ IORGLQ+LORGLQOPT-1,
$ IBBCSD+LBBCSD-1 )
WORK(1) = LWORKOPT
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
END IF
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'DORCSD2BY1', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
LORGQR = LWORK-IORGQR+1
LORGLQ = LWORK-IORGLQ+1
*
* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
* in which R = MIN(P,M-P,Q,M-Q)
*
IF( R .EQ. Q ) THEN
*
* Case 1: R = Q
*
* Simultaneously bidiagonalize X11 and X21
*
CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
$ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
$ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
*
* Accumulate Householder reflectors
*
IF( WANTU1 .AND. P .GT. 0 ) THEN
CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
$ LORGQR, CHILDINFO )
END IF
IF( WANTU2 .AND. M-P .GT. 0 ) THEN
CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
$ WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTV1T .AND. Q .GT. 0 ) THEN
V1T(1,1) = ONE
DO J = 2, Q
V1T(1,J) = ZERO
V1T(J,1) = ZERO
END DO
CALL DLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
$ LDV1T )
CALL DORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
$ WORK(IORGLQ), LORGLQ, CHILDINFO )
END IF
*
* Simultaneously diagonalize X11 and X21.
*
CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
$ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1,
$ WORK(IB11D), WORK(IB11E), WORK(IB12D),
$ WORK(IB12E), WORK(IB21D), WORK(IB21E),
$ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
$ CHILDINFO )
*
* Permute rows and columns to place zero submatrices in
* preferred positions
*
IF( Q .GT. 0 .AND. WANTU2 ) THEN
DO I = 1, Q
IWORK(I) = M - P - Q + I
END DO
DO I = Q + 1, M - P
IWORK(I) = I - Q
END DO
CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
END IF
ELSE IF( R .EQ. P ) THEN
*
* Case 2: R = P
*
* Simultaneously bidiagonalize X11 and X21
*
CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
$ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
$ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
*
* Accumulate Householder reflectors
*
IF( WANTU1 .AND. P .GT. 0 ) THEN
U1(1,1) = ONE
DO J = 2, P
U1(1,J) = ZERO
U1(J,1) = ZERO
END DO
CALL DLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
$ WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTU2 .AND. M-P .GT. 0 ) THEN
CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
$ WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTV1T .AND. Q .GT. 0 ) THEN
CALL DLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
$ WORK(IORGLQ), LORGLQ, CHILDINFO )
END IF
*
* Simultaneously diagonalize X11 and X21.
*
CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
$ WORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2,
$ WORK(IB11D), WORK(IB11E), WORK(IB12D),
$ WORK(IB12E), WORK(IB21D), WORK(IB21E),
$ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
$ CHILDINFO )
*
* Permute rows and columns to place identity submatrices in
* preferred positions
*
IF( Q .GT. 0 .AND. WANTU2 ) THEN
DO I = 1, Q
IWORK(I) = M - P - Q + I
END DO
DO I = Q + 1, M - P
IWORK(I) = I - Q
END DO
CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
END IF
ELSE IF( R .EQ. M-P ) THEN
*
* Case 3: R = M-P
*
* Simultaneously bidiagonalize X11 and X21
*
CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
$ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
$ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
*
* Accumulate Householder reflectors
*
IF( WANTU1 .AND. P .GT. 0 ) THEN
CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
$ LORGQR, CHILDINFO )
END IF
IF( WANTU2 .AND. M-P .GT. 0 ) THEN
U2(1,1) = ONE
DO J = 2, M-P
U2(1,J) = ZERO
U2(J,1) = ZERO
END DO
CALL DLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
$ LDU2 )
CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
$ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTV1T .AND. Q .GT. 0 ) THEN
CALL DLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
$ WORK(IORGLQ), LORGLQ, CHILDINFO )
END IF
*
* Simultaneously diagonalize X11 and X21.
*
CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
$ THETA, WORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, U1,
$ LDU1, WORK(IB11D), WORK(IB11E), WORK(IB12D),
$ WORK(IB12E), WORK(IB21D), WORK(IB21E),
$ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
$ CHILDINFO )
*
* Permute rows and columns to place identity submatrices in
* preferred positions
*
IF( Q .GT. R ) THEN
DO I = 1, R
IWORK(I) = Q - R + I
END DO
DO I = R + 1, Q
IWORK(I) = I - R
END DO
IF( WANTU1 ) THEN
CALL DLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
END IF
IF( WANTV1T ) THEN
CALL DLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
END IF
END IF
ELSE
*
* Case 4: R = M-Q
*
* Simultaneously bidiagonalize X11 and X21
*
CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
$ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
$ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
$ LORBDB-M, CHILDINFO )
*
* Accumulate Householder reflectors
*
IF( WANTU1 .AND. P .GT. 0 ) THEN
CALL DCOPY( P, WORK(IORBDB), 1, U1, 1 )
DO J = 2, P
U1(1,J) = ZERO
END DO
CALL DLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
$ LDU1 )
CALL DORGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
$ WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTU2 .AND. M-P .GT. 0 ) THEN
CALL DCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
DO J = 2, M-P
U2(1,J) = ZERO
END DO
CALL DLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
$ LDU2 )
CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
$ WORK(IORGQR), LORGQR, CHILDINFO )
END IF
IF( WANTV1T .AND. Q .GT. 0 ) THEN
CALL DLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
CALL DLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
$ V1T(M-Q+1,M-Q+1), LDV1T )
CALL DLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
$ V1T(P+1,P+1), LDV1T )
CALL DORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
$ WORK(IORGLQ), LORGLQ, CHILDINFO )
END IF
*
* Simultaneously diagonalize X11 and X21.
*
CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
$ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T,
$ LDV1T, WORK(IB11D), WORK(IB11E), WORK(IB12D),
$ WORK(IB12E), WORK(IB21D), WORK(IB21E),
$ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
$ CHILDINFO )
*
* Permute rows and columns to place identity submatrices in
* preferred positions
*
IF( P .GT. R ) THEN
DO I = 1, R
IWORK(I) = P - R + I
END DO
DO I = R + 1, P
IWORK(I) = I - R
END DO
IF( WANTU1 ) THEN
CALL DLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
END IF
IF( WANTV1T ) THEN
CALL DLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
END IF
END IF
END IF
*
RETURN
*
* End of DORCSD2BY1
*
END

7
lapack-netlib/SRC/dstemr.f
View File

@ -294,7 +294,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@ -312,10 +312,10 @@
$ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
@ -391,6 +391,7 @@
WU = ZERO
IIL = 0
IIU = 0
NSPLIT = 0
IF( VALEIG ) THEN
* We do not reference VL, VU in the cases RANGE = 'I','A'

258
lapack-netlib/SRC/dsycon_rook.f Normal file
View File

@ -0,0 +1,258 @@
*> \brief \b DSYCON_ROOK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYCON_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsycon_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsycon_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsycon_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND,
* WORK, IWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * ), IWORK( * )
* DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYCON_ROOK estimates the reciprocal of the condition number (in the
*> 1-norm) of a real symmetric matrix A using the factorization
*> A = U*D*U**T or A = L*D*L**T computed by DSYTRF_ROOK.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by DSYTRF_ROOK.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by DSYTRF_ROOK.
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*> ANORM is DOUBLE PRECISION
*> The 1-norm of the original matrix A.
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*> RCOND is DOUBLE PRECISION
*> The reciprocal of the condition number of the matrix A,
*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
*> estimate of the 1-norm of inv(A) computed in this routine.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup doubleSYcomputational
*
*> \par Contributors:
* ==================
*> \verbatim
*>
*> April 2012, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
$ IWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, KASE
DOUBLE PRECISION AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DSYTRS_ROOK, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYCON_ROOK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
*
CALL DSYTRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of DSYCON_ROOK
*
END

293
lapack-netlib/SRC/dsysv_rook.f Normal file
View File

@ -0,0 +1,293 @@
*> \brief <b> DSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYSV_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsysv_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsysv_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsysv_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
* LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYSV_ROOK computes the solution to a real system of linear
*> equations
*> A * X = B,
*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
*> matrices.
*>
*> The diagonal pivoting method is used to factor A as
*> A = U * D * U**T, if UPLO = 'U', or
*> A = L * D * L**T, if UPLO = 'L',
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is symmetric and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.
*>
*> DSYTRF_ROOK is called to compute the factorization of a real
*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
*> pivoting method.
*>
*> The factored form of A is then used to solve the system
*> of equations A * X = B by calling DSYTRS_ROOK.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of linear equations, i.e., the order of the
*> matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the block diagonal matrix D and the
*> multipliers used to obtain the factor U or L from the
*> factorization A = U*D*U**T or A = L*D*L**T as computed by
*> DSYTRF_ROOK.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D,
*> as determined by DSYTRF_ROOK.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS right hand side matrix B.
*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of WORK. LWORK >= 1, and for best performance
*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for
*> DSYTRF_ROOK.
*>
*> TRS will be done with Level 2 BLAS
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular, so the solution could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup doubleSYsolve
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> April 2012, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
$ LWORK, INFO )
*
* -- LAPACK driver routine (version 3.4.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, LWORK, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LWKOPT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, DSYTRF_ROOK, DSYTRS_ROOK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
LWKOPT = 1
ELSE
CALL DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO )
LWKOPT = WORK(1)
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYSV_ROOK ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Compute the factorization A = U*D*U**T or A = L*D*L**T.
*
CALL DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
* Solve with TRS_ROOK ( Use Level 2 BLAS)
*
CALL DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
END IF
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DSYSV_ROOK
*
END

37
lapack-netlib/SRC/dsytf2.f
View File

@ -90,13 +90,22 @@
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*>
*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
@ -118,7 +127,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*> \date November 2013
*
*> \ingroup doubleSYcomputational
*
@ -185,10 +194,10 @@
* =====================================================================
SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
@ -268,7 +277,8 @@
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, A( 1, K ), 1 )
@ -279,7 +289,8 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
* Column K is zero or contains a NaN: set INFO and continue
* Column K is zero or underflow, or contains a NaN:
* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
@ -436,7 +447,8 @@
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
@ -447,7 +459,8 @@
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
* Column K is zero or contains a NaN: set INFO and continue
* Column K is zero or underflow, or contains a NaN:
* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K

813
lapack-netlib/SRC/dsytf2_rook.f Normal file
View File

@ -0,0 +1,813 @@
*> \brief \b DSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYTF2_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytf2_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytf2_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytf2_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYTF2_ROOK computes the factorization of a real symmetric matrix A
*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
*>
*> A = U*D*U**T or A = L*D*L**T
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, U**T is the transpose of U, and D is symmetric and
*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
*>
*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L (see below for further details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the k-th argument had an illegal value
*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular, and division by zero will occur if it
*> is used to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup doubleSYcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**T, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**T, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> 01-01-96 - Based on modifications by
*> J. Lewis, Boeing Computer Services Company
*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA
*> \endverbatim
*
* =====================================================================
SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER, DONE
INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
$ P, II
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
$ ROWMAX, DTEMP, T, WK, WKM1, WKP1, SFMIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSWAP, DSYR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTF2_ROOK', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
* Compute machine safe minimum
*
SFMIN = DLAMCH( 'S' )
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**T using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 70
KSTEP = 1
P = K
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, A( 1, K ), 1 )
COLMAX = ABS( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
*
* Test for interchange
*
* Equivalent to testing for (used to handle NaN and Inf)
* ABSAKK.GE.ALPHA*COLMAX
*
IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
*
* no interchange,
* use 1-by-1 pivot block
*
KP = K
ELSE
*
DONE = .FALSE.
*
* Loop until pivot found
*
12 CONTINUE
*
* Begin pivot search loop body
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine both ROWMAX and JMAX.
*
IF( IMAX.NE.K ) THEN
JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ),
$ LDA )
ROWMAX = ABS( A( IMAX, JMAX ) )
ELSE
ROWMAX = ZERO
END IF
*
IF( IMAX.GT.1 ) THEN
ITEMP = IDAMAX( IMAX-1, A( 1, IMAX ), 1 )
DTEMP = ABS( A( ITEMP, IMAX ) )
IF( DTEMP.GT.ROWMAX ) THEN
ROWMAX = DTEMP
JMAX = ITEMP
END IF
END IF
*
* Equivalent to testing for (used to handle NaN and Inf)
* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
*
IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) )
$ THEN
*
* interchange rows and columns K and IMAX,
* use 1-by-1 pivot block
*
KP = IMAX
DONE = .TRUE.
*
* Equivalent to testing for ROWMAX .EQ. COLMAX,
* used to handle NaN and Inf
*
ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
*
* interchange rows and columns K+1 and IMAX,
* use 2-by-2 pivot block
*
KP = IMAX
KSTEP = 2
DONE = .TRUE.
ELSE
*
* Pivot NOT found, set variables and repeat
*
P = IMAX
COLMAX = ROWMAX
IMAX = JMAX
END IF
*
* End pivot search loop body
*
IF( .NOT. DONE ) GOTO 12
*
END IF
*
* Swap TWO rows and TWO columns
*
* First swap
*
IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
*
* Interchange rows and column K and P in the leading
* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
*
IF( P.GT.1 )
$ CALL DSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
IF( P.LT.(K-1) )
$ CALL DSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ),
$ LDA )
T = A( K, K )
A( K, K ) = A( P, P )
A( P, P ) = T
END IF
*
* Second swap
*
KK = K - KSTEP + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the leading
* submatrix A(1:k,1:k)
*
IF( KP.GT.1 )
$ CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) )
$ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K-1, K )
A( K-1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
IF( K.GT.1 ) THEN
*
* Perform a rank-1 update of A(1:k-1,1:k-1) and
* store U(k) in column k
*
IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
* A := A - U(k)*D(k)*U(k)**T
* = A - W(k)*1/D(k)*W(k)**T
*
D11 = ONE / A( K, K )
CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
*
* Store U(k) in column k
*
CALL DSCAL( K-1, D11, A( 1, K ), 1 )
ELSE
*
* Store L(k) in column K
*
D11 = A( K, K )
DO 16 II = 1, K - 1
A( II, K ) = A( II, K ) / D11
16 CONTINUE
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
* A := A - U(k)*D(k)*U(k)**T
* = A - W(k)*(1/D(k))*W(k)**T
* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
*
CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
END IF
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
*
* and store L(k) and L(k+1) in columns k and k+1
*
IF( K.GT.2 ) THEN
*
D12 = A( K-1, K )
D22 = A( K-1, K-1 ) / D12
D11 = A( K, K ) / D12
T = ONE / ( D11*D22-ONE )
*
DO 30 J = K - 2, 1, -1
*
WKM1 = T*( D11*A( J, K-1 )-A( J, K ) )
WK = T*( D22*A( J, K )-A( J, K-1 ) )
*
DO 20 I = J, 1, -1
A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK -
$ ( A( I, K-1 ) / D12 )*WKM1
20 CONTINUE
*
* Store U(k) and U(k-1) in cols k and k-1 for row J
*
A( J, K ) = WK / D12
A( J, K-1 ) = WKM1 / D12
*
30 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -P
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**T using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 70
KSTEP = 1
P = K
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
COLMAX = ABS( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
*
* Test for interchange
*
* Equivalent to testing for (used to handle NaN and Inf)
* ABSAKK.GE.ALPHA*COLMAX
*
IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
DONE = .FALSE.
*
* Loop until pivot found
*
42 CONTINUE
*
* Begin pivot search loop body
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine both ROWMAX and JMAX.
*
IF( IMAX.NE.K ) THEN
JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA )
ROWMAX = ABS( A( IMAX, JMAX ) )
ELSE
ROWMAX = ZERO
END IF
*
IF( IMAX.LT.N ) THEN
ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ),
$ 1 )
DTEMP = ABS( A( ITEMP, IMAX ) )
IF( DTEMP.GT.ROWMAX ) THEN
ROWMAX = DTEMP
JMAX = ITEMP
END IF
END IF
*
* Equivalent to testing for (used to handle NaN and Inf)
* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
*
IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) )
$ THEN
*
* interchange rows and columns K and IMAX,
* use 1-by-1 pivot block
*
KP = IMAX
DONE = .TRUE.
*
* Equivalent to testing for ROWMAX .EQ. COLMAX,
* used to handle NaN and Inf
*
ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
*
* interchange rows and columns K+1 and IMAX,
* use 2-by-2 pivot block
*
KP = IMAX
KSTEP = 2
DONE = .TRUE.
ELSE
*
* Pivot NOT found, set variables and repeat
*
P = IMAX
COLMAX = ROWMAX
IMAX = JMAX
END IF
*
* End pivot search loop body
*
IF( .NOT. DONE ) GOTO 42
*
END IF
*
* Swap TWO rows and TWO columns
*
* First swap
*
IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
*
* Interchange rows and column K and P in the trailing
* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
*
IF( P.LT.N )
$ CALL DSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
IF( P.GT.(K+1) )
$ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
T = A( K, K )
A( K, K ) = A( P, P )
A( P, P ) = T
END IF
*
* Second swap
*
KK = K + KSTEP - 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the trailing
* submatrix A(k:n,k:n)
*
IF( KP.LT.N )
$ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) )
$ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K+1, K )
A( K+1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) and
* store L(k) in column k
*
IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
* A := A - L(k)*D(k)*L(k)**T
* = A - W(k)*(1/D(k))*W(k)**T
*
D11 = ONE / A( K, K )
CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
*
* Store L(k) in column k
*
CALL DSCAL( N-K, D11, A( K+1, K ), 1 )
ELSE
*
* Store L(k) in column k
*
D11 = A( K, K )
DO 46 II = K + 1, N
A( II, K ) = A( II, K ) / D11
46 CONTINUE
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
* A := A - L(k)*D(k)*L(k)**T
* = A - W(k)*(1/D(k))*W(k)**T
* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
*
CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
END IF
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
*
* and store L(k) and L(k+1) in columns k and k+1
*
IF( K.LT.N-1 ) THEN
*
D21 = A( K+1, K )
D11 = A( K+1, K+1 ) / D21
D22 = A( K, K ) / D21
T = ONE / ( D11*D22-ONE )
*
DO 60 J = K + 2, N
*
* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
*
WK = T*( D11*A( J, K )-A( J, K+1 ) )
WKP1 = T*( D22*A( J, K+1 )-A( J, K ) )
*
* Perform a rank-2 update of A(k+2:n,k+2:n)
*
DO 50 I = J, N
A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK -
$ ( A( I, K+1 ) / D21 )*WKP1
50 CONTINUE
*
* Store L(k) and L(k+1) in cols k and k+1 for row J
*
A( J, K ) = WK / D21
A( J, K+1 ) = WKP1 / D21
*
60 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -P
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 40
*
END IF
*
70 CONTINUE
*
RETURN
*
* End of DSYTF2_ROOK
*
END

393
lapack-netlib/SRC/dsytrf_rook.f Normal file
View File

@ -0,0 +1,393 @@
*> \brief \b DSYTRF_ROOK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYTRF_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytrf_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytrf_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytrf_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYTRF_ROOK computes the factorization of a real symmetric matrix A
*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
*> The form of the factorization is
*>
*> A = U*D*U**T or A = L*D*L**T
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is symmetric and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.
*>
*> This is the blocked version of the algorithm, calling Level 3 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L (see below for further details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k-1 and -IPIV(k-1) were inerchaged,
*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
*> columns k and -IPIV(k) were interchanged and rows and
*> columns k+1 and -IPIV(k+1) were inerchaged,
*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)).
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of WORK. LWORK >=1. For best performance
*> LWORK >= N*NB, where NB is the block size returned by ILAENV.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular, and division by zero will occur if it
*> is used to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup doubleSYcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**T, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**T, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> April 2012, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DLASYF_ROOK, DSYTF2_ROOK, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size
*
NB = ILAENV( 1, 'DSYTRF_ROOK', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRF_ROOK', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF_ROOK',
$ UPLO, N, -1, -1, -1 ) )
END IF
ELSE
IWS = 1
END IF
IF( NB.LT.NBMIN )
$ NB = N
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**T using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* KB, where KB is the number of columns factorized by DLASYF_ROOK;
* KB is either NB or NB-1, or K for the last block
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 40
*
IF( K.GT.NB ) THEN
*
* Factorize columns k-kb+1:k of A and use blocked code to
* update columns 1:k-kb
*
CALL DLASYF_ROOK( UPLO, K, NB, KB, A, LDA,
$ IPIV, WORK, LDWORK, IINFO )
ELSE
*
* Use unblocked code to factorize columns 1:k of A
*
CALL DSYTF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO )
KB = K
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* No need to adjust IPIV
*
* Decrease K and return to the start of the main loop
*
K = K - KB
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**T using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* KB, where KB is the number of columns factorized by DLASYF_ROOK;
* KB is either NB or NB-1, or N-K+1 for the last block
*
K = 1
20 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 40
*
IF( K.LE.N-NB ) THEN
*
* Factorize columns k:k+kb-1 of A and use blocked code to
* update columns k+kb:n
*
CALL DLASYF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
$ IPIV( K ), WORK, LDWORK, IINFO )
ELSE
*
* Use unblocked code to factorize columns k:n of A
*
CALL DSYTF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
$ IINFO )
KB = N - K + 1
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + K - 1
*
* Adjust IPIV
*
DO 30 J = K, K + KB - 1
IF( IPIV( J ).GT.0 ) THEN
IPIV( J ) = IPIV( J ) + K - 1
ELSE
IPIV( J ) = IPIV( J ) - K + 1
END IF
30 CONTINUE
*
* Increase K and return to the start of the main loop
*
K = K + KB
GO TO 20
*
END IF
*
40 CONTINUE
WORK( 1 ) = LWKOPT
RETURN
*
* End of DSYTRF_ROOK
*
END

450
lapack-netlib/SRC/dsytri_rook.f Normal file
View File

@ -0,0 +1,450 @@
*> \brief \b DSYTRI_ROOK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYTRI_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytri_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytri_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytri_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYTRI_ROOK computes the inverse of a real symmetric
*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T
*> computed by DSYTRF_ROOK.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the block diagonal matrix D and the multipliers
*> used to obtain the factor U or L as computed by DSYTRF_ROOK.
*>
*> On exit, if INFO = 0, the (symmetric) inverse of the original
*> matrix. If UPLO = 'U', the upper triangular part of the
*> inverse is formed and the part of A below the diagonal is not
*> referenced; if UPLO = 'L' the lower triangular part of the
*> inverse is formed and the part of A above the diagonal is
*> not referenced.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by DSYTRF_ROOK.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
*> inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup doubleSYcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> April 2012, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K, KP, KSTEP
DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRI_ROOK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U**T.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 40
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / A( K, K )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( A( K, K+1 ) )
AK = A( K, K ) / T
AKP1 = A( K+1, K+1 ) / T
AKKP1 = A( K, K+1 ) / T
D = T*( AK*AKP1-ONE )
A( K, K ) = AKP1 / D
A( K+1, K+1 ) = AK / D
A( K, K+1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
$ 1 )
A( K, K+1 ) = A( K, K+1 ) -
$ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K+1 ), 1 )
A( K+1, K+1 ) = A( K+1, K+1 ) -
$ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )
END IF
KSTEP = 2
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* Interchange rows and columns K and IPIV(K) in the leading
* submatrix A(1:k+1,1:k+1)
*
KP = IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.GT.1 )
$ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
ELSE
*
* Interchange rows and columns K and K+1 with -IPIV(K) and
* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1)
*
KP = -IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.GT.1 )
$ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
*
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
TEMP = A( K, K+1 )
A( K, K+1 ) = A( KP, K+1 )
A( KP, K+1 ) = TEMP
END IF
*
K = K + 1
KP = -IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.GT.1 )
$ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
END IF
*
K = K + 1
GO TO 30
40 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L**T.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
50 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 60
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / A( K, K )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( A( K, K-1 ) )
AK = A( K-1, K-1 ) / T
AKP1 = A( K, K ) / T
AKKP1 = A( K, K-1 ) / T
D = T*( AK*AKP1-ONE )
A( K-1, K-1 ) = AKP1 / D
A( K, K ) = AK / D
A( K, K-1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
$ 1 )
A( K, K-1 ) = A( K, K-1 ) -
$ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
$ 1 )
CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K-1 ), 1 )
A( K-1, K-1 ) = A( K-1, K-1 ) -
$ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )
END IF
KSTEP = 2
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* Interchange rows and columns K and IPIV(K) in the trailing
* submatrix A(k-1:n,k-1:n)
*
KP = IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.LT.N )
$ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
ELSE
*
* Interchange rows and columns K and K-1 with -IPIV(K) and
* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
*
KP = -IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.LT.N )
$ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
*
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
TEMP = A( K, K-1 )
A( K, K-1 ) = A( KP, K-1 )
A( KP, K-1 ) = TEMP
END IF
*
K = K - 1
KP = -IPIV( K )
IF( KP.NE.K ) THEN
IF( KP.LT.N )
$ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
END IF
END IF
*
K = K - 1
GO TO 50
60 CONTINUE
END IF
*
RETURN
*
* End of DSYTRI_ROOK
*
END

484
lapack-netlib/SRC/dsytrs_rook.f Normal file
View File

@ -0,0 +1,484 @@
*> \brief \b DSYTRS_ROOK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYTRS_ROOK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytrs_rook.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytrs_rook.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytrs_rook.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYTRS_ROOK solves a system of linear equations A*X = B with
*> a real symmetric matrix A using the factorization A = U*D*U**T or
*> A = L*D*L**T computed by DSYTRF_ROOK.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by DSYTRF_ROOK.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by DSYTRF_ROOK.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*> On entry, the right hand side matrix B.
*> On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup doubleSYcomputational
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> April 2012, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*>
*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
*> School of Mathematics,
*> University of Manchester
*>
*> \endverbatim
*
* =====================================================================
SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KP
DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRS_ROOK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U**T.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL DGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K-1 )
IF( KP.NE.K-1 )
$ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.GT.2 ) THEN
CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ),
$ LDB, B( 1, 1 ), LDB )
CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
$ LDB, B( 1, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K-1, K )
AKM1 = A( K-1, K-1 ) / AKM1K
AK = A( K, K ) / AKM1K
DENOM = AKM1*AK - ONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / AKM1K
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U**T *X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U**T(K)), where U(K) is the transformation
* stored in column K of A.
*
IF( K.GT.1 )
$ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B,
$ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.GT.1 ) THEN
CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B,
$ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B,
$ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
END IF
*
* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K+1 )
IF( KP.NE.K+1 )
$ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L**T.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL DGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1)
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K+1 )
IF( KP.NE.K+1 )
$ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K+1, K )
AKM1 = A( K, K ) / AKM1K
AK = A( K+1, K+1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / AKM1K
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L**T *X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L**T(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ),
$ LDB )
END IF
*
* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
KP = -IPIV( K-1 )
IF( KP.NE.K-1 )
$ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of DSYTRS_ROOK
*
END

20
lapack-netlib/SRC/dtpmqrt.f
View File

@ -175,7 +175,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@ -216,10 +216,10 @@
SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT,
$ A, LDA, B, LDB, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@ -235,7 +235,7 @@
* ..
* .. Local Scalars ..
LOGICAL LEFT, RIGHT, TRAN, NOTRAN
INTEGER I, IB, MB, LB, KF, Q
INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ
* ..
* .. External Functions ..
LOGICAL LSAME
@ -258,9 +258,11 @@
NOTRAN = LSAME( TRANS, 'N' )
*
IF ( LEFT ) THEN
Q = M
LDVQ = MAX( 1, M )
LDAQ = MAX( 1, K )
ELSE IF ( RIGHT ) THEN
Q = N
LDVQ = MAX( 1, N )
LDAQ = MAX( 1, M )
END IF
IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
INFO = -1
@ -274,13 +276,13 @@
INFO = -5
ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
INFO = -6
ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN
INFO = -7
ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
ELSE IF( LDV.LT.LDVQ ) THEN
INFO = -9
ELSE IF( LDT.LT.NB ) THEN
INFO = -11
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
ELSE IF( LDA.LT.LDAQ ) THEN
INFO = -13
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -15

10
lapack-netlib/SRC/dtpqrt.f
View File

@ -132,7 +132,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*> \date November 2013
*
*> \ingroup doubleOTHERcomputational
*
@ -189,10 +189,10 @@
SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LDT, N, M, L, NB
@ -219,9 +219,9 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
INFO = -3
ELSE IF( NB.LT.1 .OR. NB.GT.N ) THEN
ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6

8
lapack-netlib/SRC/ilaver.f
View File

@ -48,18 +48,18 @@
* =====================================================================
SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
* November 2013
*
* =====================================================================
*
INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
* =====================================================================
VERS_MAJOR = 3
VERS_MINOR = 4
VERS_PATCH = 2
VERS_MINOR = 5
VERS_PATCH = 0
* =====================================================================
*
RETURN

31
lapack-netlib/SRC/sbbcsd.f
View File

@ -322,7 +322,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup realOTHERcomputational
*
@ -332,10 +332,10 @@
$ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E,
$ B22D, B22E, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS
@ -358,8 +358,8 @@
PARAMETER ( HUNDRED = 100.0E0, MEIGHTH = -0.125E0,
$ ONE = 1.0E0, PIOVER2 = 1.57079632679489662E0,
$ TEN = 10.0E0, ZERO = 0.0E0 )
REAL NEGONECOMPLEX
PARAMETER ( NEGONECOMPLEX = -1.0E0 )
REAL NEGONE
PARAMETER ( NEGONE = -1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL COLMAJOR, LQUERY, RESTART11, RESTART12,
@ -477,7 +477,10 @@
* Initial deflation
*
IMAX = Q
DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) )
DO WHILE( IMAX .GT. 1 )
IF( PHI(IMAX-1) .NE. ZERO ) THEN
EXIT
END IF
IMAX = IMAX - 1
END DO
IMIN = IMAX - 1
@ -939,9 +942,9 @@
B21D(IMAX) = -B21D(IMAX)
IF( WANTV1T ) THEN
IF( COLMAJOR ) THEN
CALL SSCAL( Q, NEGONECOMPLEX, V1T(IMAX,1), LDV1T )
CALL SSCAL( Q, NEGONE, V1T(IMAX,1), LDV1T )
ELSE
CALL SSCAL( Q, NEGONECOMPLEX, V1T(1,IMAX), 1 )
CALL SSCAL( Q, NEGONE, V1T(1,IMAX), 1 )
END IF
END IF
END IF
@ -962,9 +965,9 @@
B12D(IMAX) = -B12D(IMAX)
IF( WANTU1 ) THEN
IF( COLMAJOR ) THEN
CALL SSCAL( P, NEGONECOMPLEX, U1(1,IMAX), 1 )
CALL SSCAL( P, NEGONE, U1(1,IMAX), 1 )
ELSE
CALL SSCAL( P, NEGONECOMPLEX, U1(IMAX,1), LDU1 )
CALL SSCAL( P, NEGONE, U1(IMAX,1), LDU1 )
END IF
END IF
END IF
@ -972,9 +975,9 @@
B22D(IMAX) = -B22D(IMAX)
IF( WANTU2 ) THEN
IF( COLMAJOR ) THEN
CALL SSCAL( M-P, NEGONECOMPLEX, U2(1,IMAX), 1 )
CALL SSCAL( M-P, NEGONE, U2(1,IMAX), 1 )
ELSE
CALL SSCAL( M-P, NEGONECOMPLEX, U2(IMAX,1), LDU2 )
CALL SSCAL( M-P, NEGONE, U2(IMAX,1), LDU2 )
END IF
END IF
END IF
@ -984,9 +987,9 @@
IF( B12D(IMAX)+B22D(IMAX) .LT. 0 ) THEN
IF( WANTV2T ) THEN
IF( COLMAJOR ) THEN
CALL SSCAL( M-Q, NEGONECOMPLEX, V2T(IMAX,1), LDV2T )
CALL SSCAL( M-Q, NEGONE, V2T(IMAX,1), LDV2T )
ELSE
CALL SSCAL( M-Q, NEGONECOMPLEX, V2T(1,IMAX), 1 )
CALL SSCAL( M-Q, NEGONE, V2T(1,IMAX), 1 )
END IF
END IF
END IF

20
lapack-netlib/SRC/sgebal.f
View File

@ -121,7 +121,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup realGEcomputational
*
@ -160,10 +160,10 @@
* =====================================================================
SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOB
@ -192,8 +192,8 @@
* .. External Functions ..
LOGICAL SISNAN, LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL SISNAN, LSAME, ISAMAX, SLAMCH
REAL SLAMCH, SNRM2
EXTERNAL SISNAN, LSAME, ISAMAX, SLAMCH, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSWAP, XERBLA
@ -316,15 +316,9 @@
NOCONV = .FALSE.
*
DO 200 I = K, L
C = ZERO
R = ZERO
*
DO 150 J = K, L
IF( J.EQ.I )
$ GO TO 150
C = C + ABS( A( J, I ) )
R = R + ABS( A( I, J ) )
150 CONTINUE
C = SNRM2( L-K+1, A( K, I ), 1 )
R = SNRM2( L-K+1, A( I, K ), LDA )
ICA = ISAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = ISAMAX( N-K+1, A( I, K ), LDA )

8
lapack-netlib/SRC/sgemqrt.f
View File

@ -160,7 +160,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup realGEcomputational
*
@ -168,10 +168,10 @@
SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
@ -225,7 +225,7 @@
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN
INFO = -5
ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN
ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN
INFO = -6
ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN
INFO = -8

8
lapack-netlib/SRC/sgeqrt.f
View File

@ -108,7 +108,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*> \date November 2013
*
*> \ingroup realGEcomputational
*
@ -141,10 +141,10 @@
* =====================================================================
SUBROUTINE SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
* November 2013
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDT, M, N, NB
@ -173,7 +173,7 @@
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN
ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5

Some files were not shown because too many files have changed in this diff Show More