piqp-octave/ 0000755 0001751 0000177 00000000000 14635516624 012667 5 ustar runner docker piqp-octave/src/ 0000755 0001751 0000177 00000000000 14635516624 013456 5 ustar runner docker piqp-octave/src/eigen/ 0000755 0001751 0000177 00000000000 14107270226 014532 5 ustar runner docker piqp-octave/src/eigen/COPYING.MPL2 0000644 0001751 0000177 00000040526 14107270226 016305 0 ustar runner docker Mozilla Public License Version 2.0
==================================
1. Definitions
--------------
1.1. "Contributor"
means each individual or legal entity that creates, contributes to
the creation of, or owns Covered Software.
1.2. "Contributor Version"
means the combination of the Contributions of others (if any) used
by a Contributor and that particular Contributor's Contribution.
1.3. "Contribution"
means Covered Software of a particular Contributor.
1.4. "Covered Software"
means Source Code Form to which the initial Contributor has attached
the notice in Exhibit A, the Executable Form of such Source Code
Form, and Modifications of such Source Code Form, in each case
including portions thereof.
1.5. "Incompatible With Secondary Licenses"
means
(a) that the initial Contributor has attached the notice described
in Exhibit B to the Covered Software; or
(b) that the Covered Software was made available under the terms of
version 1.1 or earlier of the License, but not also under the
terms of a Secondary License.
1.6. "Executable Form"
means any form of the work other than Source Code Form.
1.7. "Larger Work"
means a work that combines Covered Software with other material, in
a separate file or files, that is not Covered Software.
1.8. "License"
means this document.
1.9. "Licensable"
means having the right to grant, to the maximum extent possible,
whether at the time of the initial grant or subsequently, any and
all of the rights conveyed by this License.
1.10. "Modifications"
means any of the following:
(a) any file in Source Code Form that results from an addition to,
deletion from, or modification of the contents of Covered
Software; or
(b) any new file in Source Code Form that contains any Covered
Software.
1.11. "Patent Claims" of a Contributor
means any patent claim(s), including without limitation, method,
process, and apparatus claims, in any patent Licensable by such
Contributor that would be infringed, but for the grant of the
License, by the making, using, selling, offering for sale, having
made, import, or transfer of either its Contributions or its
Contributor Version.
1.12. "Secondary License"
means either the GNU General Public License, Version 2.0, the GNU
Lesser General Public License, Version 2.1, the GNU Affero General
Public License, Version 3.0, or any later versions of those
licenses.
1.13. "Source Code Form"
means the form of the work preferred for making modifications.
1.14. "You" (or "Your")
means an individual or a legal entity exercising rights under this
License. For legal entities, "You" includes any entity that
controls, is controlled by, or is under common control with You. For
purposes of this definition, "control" means (a) the power, direct
or indirect, to cause the direction or management of such entity,
whether by contract or otherwise, or (b) ownership of more than
fifty percent (50%) of the outstanding shares or beneficial
ownership of such entity.
2. License Grants and Conditions
--------------------------------
2.1. Grants
Each Contributor hereby grants You a world-wide, royalty-free,
non-exclusive license:
(a) under intellectual property rights (other than patent or trademark)
Licensable by such Contributor to use, reproduce, make available,
modify, display, perform, distribute, and otherwise exploit its
Contributions, either on an unmodified basis, with Modifications, or
as part of a Larger Work; and
(b) under Patent Claims of such Contributor to make, use, sell, offer
for sale, have made, import, and otherwise transfer either its
Contributions or its Contributor Version.
2.2. Effective Date
The licenses granted in Section 2.1 with respect to any Contribution
become effective for each Contribution on the date the Contributor first
distributes such Contribution.
2.3. Limitations on Grant Scope
The licenses granted in this Section 2 are the only rights granted under
this License. No additional rights or licenses will be implied from the
distribution or licensing of Covered Software under this License.
Notwithstanding Section 2.1(b) above, no patent license is granted by a
Contributor:
(a) for any code that a Contributor has removed from Covered Software;
or
(b) for infringements caused by: (i) Your and any other third party's
modifications of Covered Software, or (ii) the combination of its
Contributions with other software (except as part of its Contributor
Version); or
(c) under Patent Claims infringed by Covered Software in the absence of
its Contributions.
This License does not grant any rights in the trademarks, service marks,
or logos of any Contributor (except as may be necessary to comply with
the notice requirements in Section 3.4).
2.4. Subsequent Licenses
No Contributor makes additional grants as a result of Your choice to
distribute the Covered Software under a subsequent version of this
License (see Section 10.2) or under the terms of a Secondary License (if
permitted under the terms of Section 3.3).
2.5. Representation
Each Contributor represents that the Contributor believes its
Contributions are its original creation(s) or it has sufficient rights
to grant the rights to its Contributions conveyed by this License.
2.6. Fair Use
This License is not intended to limit any rights You have under
applicable copyright doctrines of fair use, fair dealing, or other
equivalents.
2.7. Conditions
Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted
in Section 2.1.
3. Responsibilities
-------------------
3.1. Distribution of Source Form
All distribution of Covered Software in Source Code Form, including any
Modifications that You create or to which You contribute, must be under
the terms of this License. You must inform recipients that the Source
Code Form of the Covered Software is governed by the terms of this
License, and how they can obtain a copy of this License. You may not
attempt to alter or restrict the recipients' rights in the Source Code
Form.
3.2. Distribution of Executable Form
If You distribute Covered Software in Executable Form then:
(a) such Covered Software must also be made available in Source Code
Form, as described in Section 3.1, and You must inform recipients of
the Executable Form how they can obtain a copy of such Source Code
Form by reasonable means in a timely manner, at a charge no more
than the cost of distribution to the recipient; and
(b) You may distribute such Executable Form under the terms of this
License, or sublicense it under different terms, provided that the
license for the Executable Form does not attempt to limit or alter
the recipients' rights in the Source Code Form under this License.
3.3. Distribution of a Larger Work
You may create and distribute a Larger Work under terms of Your choice,
provided that You also comply with the requirements of this License for
the Covered Software. If the Larger Work is a combination of Covered
Software with a work governed by one or more Secondary Licenses, and the
Covered Software is not Incompatible With Secondary Licenses, this
License permits You to additionally distribute such Covered Software
under the terms of such Secondary License(s), so that the recipient of
the Larger Work may, at their option, further distribute the Covered
Software under the terms of either this License or such Secondary
License(s).
3.4. Notices
You may not remove or alter the substance of any license notices
(including copyright notices, patent notices, disclaimers of warranty,
or limitations of liability) contained within the Source Code Form of
the Covered Software, except that You may alter any license notices to
the extent required to remedy known factual inaccuracies.
3.5. Application of Additional Terms
You may choose to offer, and to charge a fee for, warranty, support,
indemnity or liability obligations to one or more recipients of Covered
Software. However, You may do so only on Your own behalf, and not on
behalf of any Contributor. You must make it absolutely clear that any
such warranty, support, indemnity, or liability obligation is offered by
You alone, and You hereby agree to indemnify every Contributor for any
liability incurred by such Contributor as a result of warranty, support,
indemnity or liability terms You offer. You may include additional
disclaimers of warranty and limitations of liability specific to any
jurisdiction.
4. Inability to Comply Due to Statute or Regulation
---------------------------------------------------
If it is impossible for You to comply with any of the terms of this
License with respect to some or all of the Covered Software due to
statute, judicial order, or regulation then You must: (a) comply with
the terms of this License to the maximum extent possible; and (b)
describe the limitations and the code they affect. Such description must
be placed in a text file included with all distributions of the Covered
Software under this License. Except to the extent prohibited by statute
or regulation, such description must be sufficiently detailed for a
recipient of ordinary skill to be able to understand it.
5. Termination
--------------
5.1. The rights granted under this License will terminate automatically
if You fail to comply with any of its terms. However, if You become
compliant, then the rights granted under this License from a particular
Contributor are reinstated (a) provisionally, unless and until such
Contributor explicitly and finally terminates Your grants, and (b) on an
ongoing basis, if such Contributor fails to notify You of the
non-compliance by some reasonable means prior to 60 days after You have
come back into compliance. Moreover, Your grants from a particular
Contributor are reinstated on an ongoing basis if such Contributor
notifies You of the non-compliance by some reasonable means, this is the
first time You have received notice of non-compliance with this License
from such Contributor, and You become compliant prior to 30 days after
Your receipt of the notice.
5.2. If You initiate litigation against any entity by asserting a patent
infringement claim (excluding declaratory judgment actions,
counter-claims, and cross-claims) alleging that a Contributor Version
directly or indirectly infringes any patent, then the rights granted to
You by any and all Contributors for the Covered Software under Section
2.1 of this License shall terminate.
5.3. In the event of termination under Sections 5.1 or 5.2 above, all
end user license agreements (excluding distributors and resellers) which
have been validly granted by You or Your distributors under this License
prior to termination shall survive termination.
************************************************************************
* *
* 6. Disclaimer of Warranty *
* ------------------------- *
* *
* Covered Software is provided under this License on an "as is" *
* basis, without warranty of any kind, either expressed, implied, or *
* statutory, including, without limitation, warranties that the *
* Covered Software is free of defects, merchantable, fit for a *
* particular purpose or non-infringing. The entire risk as to the *
* quality and performance of the Covered Software is with You. *
* Should any Covered Software prove defective in any respect, You *
* (not any Contributor) assume the cost of any necessary servicing, *
* repair, or correction. This disclaimer of warranty constitutes an *
* essential part of this License. No use of any Covered Software is *
* authorized under this License except under this disclaimer. *
* *
************************************************************************
************************************************************************
* *
* 7. Limitation of Liability *
* -------------------------- *
* *
* Under no circumstances and under no legal theory, whether tort *
* (including negligence), contract, or otherwise, shall any *
* Contributor, or anyone who distributes Covered Software as *
* permitted above, be liable to You for any direct, indirect, *
* special, incidental, or consequential damages of any character *
* including, without limitation, damages for lost profits, loss of *
* goodwill, work stoppage, computer failure or malfunction, or any *
* and all other commercial damages or losses, even if such party *
* shall have been informed of the possibility of such damages. This *
* limitation of liability shall not apply to liability for death or *
* personal injury resulting from such party's negligence to the *
* extent applicable law prohibits such limitation. Some *
* jurisdictions do not allow the exclusion or limitation of *
* incidental or consequential damages, so this exclusion and *
* limitation may not apply to You. *
* *
************************************************************************
8. Litigation
-------------
Any litigation relating to this License may be brought only in the
courts of a jurisdiction where the defendant maintains its principal
place of business and such litigation shall be governed by laws of that
jurisdiction, without reference to its conflict-of-law provisions.
Nothing in this Section shall prevent a party's ability to bring
cross-claims or counter-claims.
9. Miscellaneous
----------------
This License represents the complete agreement concerning the subject
matter hereof. If any provision of this License is held to be
unenforceable, such provision shall be reformed only to the extent
necessary to make it enforceable. Any law or regulation which provides
that the language of a contract shall be construed against the drafter
shall not be used to construe this License against a Contributor.
10. Versions of the License
---------------------------
10.1. New Versions
Mozilla Foundation is the license steward. Except as provided in Section
10.3, no one other than the license steward has the right to modify or
publish new versions of this License. Each version will be given a
distinguishing version number.
10.2. Effect of New Versions
You may distribute the Covered Software under the terms of the version
of the License under which You originally received the Covered Software,
or under the terms of any subsequent version published by the license
steward.
10.3. Modified Versions
If you create software not governed by this License, and you want to
create a new license for such software, you may create and use a
modified version of this License if you rename the license and remove
any references to the name of the license steward (except to note that
such modified license differs from this License).
10.4. Distributing Source Code Form that is Incompatible With Secondary
Licenses
If You choose to distribute Source Code Form that is Incompatible With
Secondary Licenses under the terms of this version of the License, the
notice described in Exhibit B of this License must be attached.
Exhibit A - Source Code Form License Notice
-------------------------------------------
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at http://mozilla.org/MPL/2.0/.
If it is not possible or desirable to put the notice in a particular
file, then You may include the notice in a location (such as a LICENSE
file in a relevant directory) where a recipient would be likely to look
for such a notice.
You may add additional accurate notices of copyright ownership.
Exhibit B - "Incompatible With Secondary Licenses" Notice
---------------------------------------------------------
This Source Code Form is "Incompatible With Secondary Licenses", as
defined by the Mozilla Public License, v. 2.0.
piqp-octave/src/eigen/lapack/ 0000755 0001751 0000177 00000000000 14107270226 015765 5 ustar runner docker piqp-octave/src/eigen/lapack/sladiv.f 0000644 0001751 0000177 00000005521 14107270226 017421 0 ustar runner docker *> \brief \b SLADIV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLADIV( A, B, C, D, P, Q )
*
* .. Scalar Arguments ..
* REAL A, B, C, D, P, Q
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLADIV performs complex division in real arithmetic
*>
*> a + i*b
*> 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
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] A
*> \verbatim
*> A is REAL
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is REAL
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is REAL
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is REAL
*> The scalars a, b, c, and d in the above expression.
*> \endverbatim
*>
*> \param[out] P
*> \verbatim
*> P is REAL
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is REAL
*> The scalars p and q in the above expression.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
SUBROUTINE SLADIV( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary 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 ..
REAL A, B, C, D, P, Q
* ..
*
* =====================================================================
*
* .. Local Scalars ..
REAL E, F
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. 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
END IF
*
RETURN
*
* End of SLADIV
*
END
piqp-octave/src/eigen/lapack/lu.cpp 0000644 0001751 0000177 00000005137 14107270226 017117 0 ustar runner docker // This file is part of Eigen, a lightweight C++ template library
// for linear algebra.
//
// Copyright (C) 2010-2011 Gael Guennebaud
//
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
#include "common.h"
#include
// computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges
EIGEN_LAPACK_FUNC(getrf,(int *m, int *n, RealScalar *pa, int *lda, int *ipiv, int *info))
{
*info = 0;
if(*m<0) *info = -1;
else if(*n<0) *info = -2;
else if(*lda(pa);
int nb_transpositions;
int ret = int(Eigen::internal::partial_lu_impl
::blocked_lu(*m, *n, a, *lda, ipiv, nb_transpositions));
for(int i=0; i=0)
*info = ret+1;
return 0;
}
//GETRS solves a system of linear equations
// A * X = B or A' * X = B
// with a general N-by-N matrix A using the LU factorization computed by GETRF
EIGEN_LAPACK_FUNC(getrs,(char *trans, int *n, int *nrhs, RealScalar *pa, int *lda, int *ipiv, RealScalar *pb, int *ldb, int *info))
{
*info = 0;
if(OP(*trans)==INVALID) *info = -1;
else if(*n<0) *info = -2;
else if(*nrhs<0) *info = -3;
else if(*lda(pa);
Scalar* b = reinterpret_cast(pb);
MatrixType lu(a,*n,*n,*lda);
MatrixType B(b,*n,*nrhs,*ldb);
for(int i=0; i<*n; ++i)
ipiv[i]--;
if(OP(*trans)==NOTR)
{
B = PivotsType(ipiv,*n) * B;
lu.triangularView().solveInPlace(B);
lu.triangularView().solveInPlace(B);
}
else if(OP(*trans)==TR)
{
lu.triangularView().transpose().solveInPlace(B);
lu.triangularView().transpose().solveInPlace(B);
B = PivotsType(ipiv,*n).transpose() * B;
}
else if(OP(*trans)==ADJ)
{
lu.triangularView().adjoint().solveInPlace(B);
lu.triangularView().adjoint().solveInPlace(B);
B = PivotsType(ipiv,*n).transpose() * B;
}
for(int i=0; i<*n; ++i)
ipiv[i]++;
return 0;
}
piqp-octave/src/eigen/lapack/dlarfb.f 0000644 0001751 0000177 00000054335 14107270226 017400 0 ustar runner docker *> \brief \b DLARFB
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARFB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
* T, LDT, C, LDC, WORK, LDWORK )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, SIDE, STOREV, TRANS
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
* $ WORK( LDWORK, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARFB applies a real block reflector H or its transpose H**T to a
*> real m by n matrix C, from either the left or the right.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply H or H**T from the Left
*> = 'R': apply H or H**T from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply H (No transpose)
*> = 'T': apply H**T (Transpose)
*> \endverbatim
*>
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Indicates how H is formed from a product of elementary
*> reflectors
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Indicates how the vectors which define the elementary
*> reflectors are stored:
*> = 'C': Columnwise
*> = 'R': Rowwise
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the matrix T (= the number of elementary
*> reflectors whose product defines the block reflector).
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is DOUBLE PRECISION array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
*> The matrix V. See Further Details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
*> if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] T
*> \verbatim
*> T is DOUBLE PRECISION array, dimension (LDT,K)
*> The triangular k by k matrix T in the representation of the
*> block reflector.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (LDWORK,K)
*> \endverbatim
*>
*> \param[in] LDWORK
*> \verbatim
*> LDWORK is INTEGER
*> The leading dimension of the array WORK.
*> If SIDE = 'L', LDWORK >= max(1,N);
*> if SIDE = 'R', LDWORK >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup doubleOTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored; the corresponding
*> array elements are modified but restored on exit. The rest of the
*> array is not used.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK auxiliary 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 DIRECT, SIDE, STOREV, TRANS
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J, LASTV, LASTC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILADLR, ILADLC
EXTERNAL LSAME, ILADLR, ILADLC
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DTRMM
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
IF( LSAME( STOREV, 'C' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 ) (first K rows)
* ( V2 )
* where V1 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* 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 )
10 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2**T *V2
*
CALL DGEMM( 'Transpose', 'No transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - V * W**T
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - V2 * W**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTV-K, LASTC, 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 )
*
* C1 := C1 - W**T
*
DO 30 J = 1, K
DO 20 I = 1, LASTC
C( J, I ) = C( J, I ) - WORK( I, J )
20 CONTINUE
30 CONTINUE
*
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 )
40 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - W * V**T
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - W * V2**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, LASTV-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 )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, LASTC
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
ELSE
*
* Let V = ( V1 )
* ( V2 ) (last K rows)
* where V2 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* 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 := C2**T
*
DO 70 J = 1, K
CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1**T*V1
*
CALL DGEMM( 'Transpose', 'No transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - V * W**T
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1 * W**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTV-K, LASTC, 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( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 90 J = 1, K
DO 80 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J)
80 CONTINUE
90 CONTINUE
*
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 := C2
*
DO 100 J = 1, K
CALL DCOPY( LASTC, 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( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - W * V**T
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, LASTV-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( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
110 CONTINUE
120 CONTINUE
END IF
END IF
*
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 V2 ) (V1: first K columns)
* where V1 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* 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 )
130 CONTINUE
*
* W := W * V1**T
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.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 )
END IF
*
* W := W * T**T or W * T
*
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
IF( LASTV.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 )
END IF
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 150 J = 1, K
DO 140 I = 1, LASTC
C( J, I ) = C( J, I ) - WORK( I, J )
140 CONTINUE
150 CONTINUE
*
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 )
160 CONTINUE
*
* W := W * V1**T
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - W * V
*
IF( LASTV.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 )
END IF
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, LASTC
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
*
END IF
*
ELSE
*
* Let V = ( V1 V2 ) (V2: last K columns)
* where V2 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* 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 := C2**T
*
DO 190 J = 1, K
CALL DCOPY( LASTC, C( LASTV-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, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1**T * V1**T
*
CALL DGEMM( 'Transpose', 'Transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - V**T * W**T
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1**T * W**T
*
CALL DGEMM( 'Transpose', 'Transpose',
$ LASTV-K, LASTC, 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, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 210 J = 1, K
DO 200 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-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 )
*
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 := C2
*
DO 220 J = 1, K
CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1,
$ WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**T
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1**T
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-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, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
230 CONTINUE
240 CONTINUE
*
END IF
*
END IF
END IF
*
RETURN
*
* End of DLARFB
*
END
piqp-octave/src/eigen/lapack/ilaclc.f 0000644 0001751 0000177 00000005615 14107270226 017372 0 ustar runner docker *> \brief \b ILACLC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILACLC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILACLC( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILACLC scans A for its last non-zero column.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexOTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILACLC( M, N, A, LDA )
*
* -- LAPACK auxiliary 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
COMPLEX A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER ( ZERO = (0.0E+0, 0.0E+0) )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILACLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILACLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILACLC = N, 1, -1
DO I = 1, M
IF( A(I, ILACLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
piqp-octave/src/eigen/lapack/zladiv.f 0000644 0001751 0000177 00000004474 14107270226 017436 0 ustar runner docker *> \brief \b ZLADIV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* COMPLEX*16 FUNCTION ZLADIV( X, Y )
*
* .. Scalar Arguments ..
* COMPLEX*16 X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLADIV := X / Y, where X and Y are complex. The computation of X / Y
*> will not overflow on an intermediary step unless the results
*> overflows.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX*16
*> The complex scalars X and Y.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
COMPLEX*16 FUNCTION ZLADIV( X, Y )
*
* -- LAPACK auxiliary 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 ..
COMPLEX*16 X, Y
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION ZI, ZR
* ..
* .. External Subroutines ..
EXTERNAL DLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG
* ..
* .. Executable Statements ..
*
CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
$ ZI )
ZLADIV = DCMPLX( ZR, ZI )
*
RETURN
*
* End of ZLADIV
*
END
piqp-octave/src/eigen/lapack/iladlr.f 0000644 0001751 0000177 00000005670 14107270226 017413 0 ustar runner docker *> \brief \b ILADLR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILADLR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILADLR( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILADLR scans A for its last non-zero row.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILADLR( M, N, A, LDA )
*
* -- LAPACK auxiliary 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( M.EQ.0 ) THEN
ILADLR = M
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILADLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILADLR = 0
DO J = 1, N
I=M
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
I=I-1
ENDDO
ILADLR = MAX( ILADLR, I )
END DO
END IF
RETURN
END
piqp-octave/src/eigen/lapack/ilaslc.f 0000644 0001751 0000177 00000005575 14107270226 017417 0 ustar runner docker *> \brief \b ILASLC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILASLC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILASLC( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* REAL A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILASLC scans A for its last non-zero column.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is REAL array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup realOTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILASLC( M, N, A, LDA )
*
* -- LAPACK auxiliary 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILASLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILASLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILASLC = N, 1, -1
DO I = 1, M
IF( A(I, ILASLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
piqp-octave/src/eigen/lapack/dsecnd_NONE.f 0000644 0001751 0000177 00000002402 14107270226 020211 0 ustar runner docker *> \brief \b DSECND returns nothing
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DSECND( )
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSECND returns nothing instead of returning the user time for a process in seconds.
*> If you are using that routine, it means that neither EXTERNAL ETIME,
*> EXTERNAL ETIME_, INTERNAL ETIME, INTERNAL CPU_TIME is available on
*> your machine.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION DSECND( )
*
* -- LAPACK auxiliary 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
*
* =====================================================================
*
DSECND = 0.0D+0
RETURN
*
* End of DSECND
*
END
piqp-octave/src/eigen/lapack/clarfg.f 0000644 0001751 0000177 00000012340 14107270226 017372 0 ustar runner docker *> \brief \b CLARFG
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLARFG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* COMPLEX ALPHA, TAU
* ..
* .. Array Arguments ..
* COMPLEX X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLARFG generates a complex elementary reflector H of order n, such
*> that
*>
*> H**H * ( alpha ) = ( beta ), H**H * H = I.
*> ( x ) ( 0 )
*>
*> where alpha and beta are scalars, with beta real, and x is an
*> (n-1)-element complex vector. H is represented in the form
*>
*> H = I - tau * ( 1 ) * ( 1 v**H ) ,
*> ( v )
*>
*> where tau is a complex scalar and v is a complex (n-1)-element
*> vector. Note that H is not hermitian.
*>
*> If the elements of x are all zero and alpha is real, then tau = 0
*> and H is taken to be the unit matrix.
*>
*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the elementary reflector.
*> \endverbatim
*>
*> \param[in,out] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, the value alpha.
*> On exit, it is overwritten with the value beta.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, dimension
*> (1+(N-2)*abs(INCX))
*> On entry, the vector x.
*> On exit, it is overwritten with the vector v.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between elements of X. INCX > 0.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX
*> The value tau.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexOTHERauxiliary
*
* =====================================================================
SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary 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 ..
INTEGER INCX, N
COMPLEX ALPHA, TAU
* ..
* .. Array Arguments ..
COMPLEX X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
REAL ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
REAL SCNRM2, SLAMCH, SLAPY3
COMPLEX CLADIV
EXTERNAL SCNRM2, SLAMCH, SLAPY3, CLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, AIMAG, CMPLX, REAL, SIGN
* ..
* .. External Subroutines ..
EXTERNAL CSCAL, CSSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = SCNRM2( N-1, X, INCX )
ALPHR = REAL( ALPHA )
ALPHI = AIMAG( ALPHA )
*
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
RSAFMN = ONE / SAFMIN
*
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
10 CONTINUE
KNT = KNT + 1
CALL CSSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHI = ALPHI*RSAFMN
ALPHR = ALPHR*RSAFMN
IF( ABS( BETA ).LT.SAFMIN )
$ GO TO 10
*
* New BETA is at most 1, at least SAFMIN
*
XNORM = SCNRM2( N-1, X, INCX )
ALPHA = CMPLX( ALPHR, ALPHI )
BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
END IF
TAU = CMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA )
CALL CSCAL( N-1, ALPHA, X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
DO 20 J = 1, KNT
BETA = BETA*SAFMIN
20 CONTINUE
ALPHA = BETA
END IF
*
RETURN
*
* End of CLARFG
*
END
piqp-octave/src/eigen/lapack/slapy3.f 0000644 0001751 0000177 00000005215 14107270226 017352 0 ustar runner docker *> \brief \b SLAPY3
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAPY3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* REAL FUNCTION SLAPY3( X, Y, Z )
*
* .. Scalar Arguments ..
* REAL X, Y, Z
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
*> unnecessary overflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is REAL
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is REAL
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is REAL
*> X, Y and Z specify the values x, y and z.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
REAL FUNCTION SLAPY3( X, Y, Z )
*
* -- LAPACK auxiliary 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 ..
REAL X, Y, Z
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
REAL W, XABS, YABS, ZABS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
XABS = ABS( X )
YABS = ABS( Y )
ZABS = ABS( Z )
W = MAX( XABS, YABS, ZABS )
IF( W.EQ.ZERO ) THEN
* W can be zero for max(0,nan,0)
* adding all three entries together will make sure
* NaN will not disappear.
SLAPY3 = XABS + YABS + ZABS
ELSE
SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
$ ( ZABS / W )**2 )
END IF
RETURN
*
* End of SLAPY3
*
END
piqp-octave/src/eigen/lapack/ilazlc.f 0000644 0001751 0000177 00000005622 14107270226 017417 0 ustar runner docker *> \brief \b ILAZLC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILAZLC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILAZLC( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILAZLC scans A for its last non-zero column.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILAZLC( M, N, A, LDA )
*
* -- LAPACK auxiliary 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILAZLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILAZLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILAZLC = N, 1, -1
DO I = 1, M
IF( A(I, ILAZLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
piqp-octave/src/eigen/lapack/complex_single.cpp 0000644 0001751 0000177 00000001101 14107270226 021472 0 ustar runner docker // This file is part of Eigen, a lightweight C++ template library
// for linear algebra.
//
// Copyright (C) 2009-2014 Gael Guennebaud
//
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
#define SCALAR std::complex
#define SCALAR_SUFFIX c
#define SCALAR_SUFFIX_UP "C"
#define REAL_SCALAR_SUFFIX s
#define ISCOMPLEX 1
#include "cholesky.cpp"
#include "lu.cpp"
#include "svd.cpp"
piqp-octave/src/eigen/lapack/clarft.f 0000644 0001751 0000177 00000024322 14107270226 017412 0 ustar runner docker *> \brief \b CLARFT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLARFT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, STOREV
* INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
* COMPLEX T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLARFT forms the triangular factor T of a complex block reflector H
*> of order n, which is defined as a product of k elementary reflectors.
*>
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*>
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*>
*> If STOREV = 'C', the vector which defines the elementary reflector
*> H(i) is stored in the i-th column of the array V, and
*>
*> H = I - V * T * V**H
*>
*> If STOREV = 'R', the vector which defines the elementary reflector
*> H(i) is stored in the i-th row of the array V, and
*>
*> H = I - V**H * T * V
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Specifies the order in which the elementary reflectors are
*> multiplied to form the block reflector:
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Specifies how the vectors which define the elementary
*> reflectors are stored (see also Further Details):
*> = 'C': columnwise
*> = 'R': rowwise
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the block reflector H. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the triangular factor T (= the number of
*> elementary reflectors). K >= 1.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,N) if STOREV = 'R'
*> The matrix V. See further details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX array, dimension (LDT,K)
*> The k by k triangular factor T of the block reflector.
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*> lower triangular. The rest of the array is not used.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complexOTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK auxiliary 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 DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
COMPLEX T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE, ZERO
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ),
$ ZERO = ( 0.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, PREVLASTV, LASTV
* ..
* .. External Subroutines ..
EXTERNAL CGEMV, CLACGV, CTRMV
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
PREVLASTV = N
DO I = 1, K
PREVLASTV = MAX( PREVLASTV, I )
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = 1, I
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * CONJG( V( I , J ) )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i)
*
CALL CGEMV( 'Conjugate transpose', J-I, I-1,
$ -TAU( I ), V( I+1, 1 ), LDV,
$ V( I+1, I ), 1,
$ ONE, T( 1, I ), 1 )
ELSE
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * V( J , I )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H
*
CALL CGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ),
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV,
$ ONE, T( 1, I ), LDT )
END IF
*
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
*
CALL CTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
$ LDT, T( 1, I ), 1 )
T( I, I ) = TAU( I )
IF( I.GT.1 ) THEN
PREVLASTV = MAX( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
END DO
ELSE
PREVLASTV = 1
DO I = K, 1, -1
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = I, K
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( I.LT.K ) THEN
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i)
*
CALL CGEMV( 'Conjugate transpose', N-K+I-J, K-I,
$ -TAU( I ), V( J, I+1 ), LDV, V( J, I ),
$ 1, ONE, T( I+1, I ), 1 )
ELSE
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * V( J, N-K+I )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H
*
CALL CGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ),
$ V( I+1, J ), LDV, V( I, J ), LDV,
$ ONE, T( I+1, I ), LDT )
END IF
*
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
*
CALL CTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
IF( I.GT.1 ) THEN
PREVLASTV = MIN( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
T( I, I ) = TAU( I )
END IF
END DO
END IF
RETURN
*
* End of CLARFT
*
END
piqp-octave/src/eigen/lapack/ilaslr.f 0000644 0001751 0000177 00000005654 14107270226 017434 0 ustar runner docker *> \brief \b ILASLR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILASLR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILASLR( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* REAL A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILASLR scans A for its last non-zero row.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is REAL array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup realOTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILASLR( M, N, A, LDA )
*
* -- LAPACK auxiliary 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( M.EQ.0 ) THEN
ILASLR = M
ELSEIF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILASLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILASLR = 0
DO J = 1, N
I=M
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
I=I-1
ENDDO
ILASLR = MAX( ILASLR, I )
END DO
END IF
RETURN
END
piqp-octave/src/eigen/lapack/complex_double.cpp 0000644 0001751 0000177 00000001102 14107270226 021464 0 ustar runner docker // This file is part of Eigen, a lightweight C++ template library
// for linear algebra.
//
// Copyright (C) 2009-2014 Gael Guennebaud
//
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
#define SCALAR std::complex
#define SCALAR_SUFFIX z
#define SCALAR_SUFFIX_UP "Z"
#define REAL_SCALAR_SUFFIX d
#define ISCOMPLEX 1
#include "cholesky.cpp"
#include "lu.cpp"
#include "svd.cpp"
piqp-octave/src/eigen/lapack/slamch.f 0000644 0001751 0000177 00000012215 14107270226 017404 0 ustar runner docker *> \brief \b SLAMCH
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* REAL FUNCTION SLAMCH( CMACH )
*
* .. Scalar Arguments ..
* CHARACTER CMACH
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAMCH determines single precision machine parameters.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] CMACH
*> \verbatim
*> Specifies the value to be returned by SLAMCH:
*> = 'E' or 'e', SLAMCH := eps
*> = 'S' or 's , SLAMCH := sfmin
*> = 'B' or 'b', SLAMCH := base
*> = 'P' or 'p', SLAMCH := eps*base
*> = 'N' or 'n', SLAMCH := t
*> = 'R' or 'r', SLAMCH := rnd
*> = 'M' or 'm', SLAMCH := emin
*> = 'U' or 'u', SLAMCH := rmin
*> = 'L' or 'l', SLAMCH := emax
*> = 'O' or 'o', SLAMCH := rmax
*> where
*> eps = relative machine precision
*> sfmin = safe minimum, such that 1/sfmin does not overflow
*> base = base of the machine
*> prec = eps*base
*> t = number of (base) digits in the mantissa
*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
*> emin = minimum exponent before (gradual) underflow
*> rmin = underflow threshold - base**(emin-1)
*> emax = largest exponent before overflow
*> rmax = overflow threshold - (base**emax)*(1-eps)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
REAL FUNCTION SLAMCH( CMACH )
*
* -- LAPACK auxiliary 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 CMACH
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
REAL RND, EPS, SFMIN, SMALL, RMACH
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT,
$ MINEXPONENT, RADIX, TINY
* ..
* .. Executable Statements ..
*
*
* Assume rounding, not chopping. Always.
*
RND = ONE
*
IF( ONE.EQ.RND ) THEN
EPS = EPSILON(ZERO) * 0.5
ELSE
EPS = EPSILON(ZERO)
END IF
*
IF( LSAME( CMACH, 'E' ) ) THEN
RMACH = EPS
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
SFMIN = TINY(ZERO)
SMALL = ONE / HUGE(ZERO)
IF( SMALL.GE.SFMIN ) THEN
*
* Use SMALL plus a bit, to avoid the possibility of rounding
* causing overflow when computing 1/sfmin.
*
SFMIN = SMALL*( ONE+EPS )
END IF
RMACH = SFMIN
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
RMACH = RADIX(ZERO)
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
RMACH = EPS * RADIX(ZERO)
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
RMACH = DIGITS(ZERO)
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
RMACH = RND
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
RMACH = MINEXPONENT(ZERO)
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
RMACH = tiny(zero)
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
RMACH = MAXEXPONENT(ZERO)
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
RMACH = HUGE(ZERO)
ELSE
RMACH = ZERO
END IF
*
SLAMCH = RMACH
RETURN
*
* End of SLAMCH
*
END
************************************************************************
*> \brief \b SLAMC3
*> \details
*> \b Purpose:
*> \verbatim
*> SLAMC3 is intended to force A and B to be stored prior to doing
*> the addition of A and B , for use in situations where optimizers
*> might hold one of these in a register.
*> \endverbatim
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
*> \date November 2011
*> \ingroup auxOTHERauxiliary
*>
*> \param[in] A
*> \verbatim
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> The values A and B.
*> \endverbatim
*>
*
REAL FUNCTION SLAMC3( A, B )
*
* -- LAPACK auxiliary routine (version 3.4.0) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2010
*
* .. Scalar Arguments ..
REAL A, B
* ..
* =====================================================================
*
* .. Executable Statements ..
*
SLAMC3 = A + B
*
RETURN
*
* End of SLAMC3
*
END
*
************************************************************************
piqp-octave/src/eigen/lapack/slapy2.f 0000644 0001751 0000177 00000004672 14107270226 017357 0 ustar runner docker *> \brief \b SLAPY2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAPY2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* REAL FUNCTION SLAPY2( X, Y )
*
* .. Scalar Arguments ..
* REAL X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
*> overflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is REAL
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is REAL
*> X and Y specify the values x and y.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
REAL FUNCTION SLAPY2( X, Y )
*
* -- LAPACK auxiliary 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 ..
REAL X, Y
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
* ..
* .. Local Scalars ..
REAL W, XABS, YABS, Z
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
XABS = ABS( X )
YABS = ABS( Y )
W = MAX( XABS, YABS )
Z = MIN( XABS, YABS )
IF( Z.EQ.ZERO ) THEN
SLAPY2 = W
ELSE
SLAPY2 = W*SQRT( ONE+( Z / W )**2 )
END IF
RETURN
*
* End of SLAPY2
*
END
piqp-octave/src/eigen/lapack/zlarft.f 0000644 0001751 0000177 00000024325 14107270226 017444 0 ustar runner docker *> \brief \b ZLARFT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, STOREV
* INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARFT forms the triangular factor T of a complex block reflector H
*> of order n, which is defined as a product of k elementary reflectors.
*>
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*>
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*>
*> If STOREV = 'C', the vector which defines the elementary reflector
*> H(i) is stored in the i-th column of the array V, and
*>
*> H = I - V * T * V**H
*>
*> If STOREV = 'R', the vector which defines the elementary reflector
*> H(i) is stored in the i-th row of the array V, and
*>
*> H = I - V**H * T * V
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Specifies the order in which the elementary reflectors are
*> multiplied to form the block reflector:
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Specifies how the vectors which define the elementary
*> reflectors are stored (see also Further Details):
*> = 'C': columnwise
*> = 'R': rowwise
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the block reflector H. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the triangular factor T (= the number of
*> elementary reflectors). K >= 1.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX*16 array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,N) if STOREV = 'R'
*> The matrix V. See further details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,K)
*> The k by k triangular factor T of the block reflector.
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*> lower triangular. The rest of the array is not used.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK auxiliary 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 DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, PREVLASTV, LASTV
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZLACGV, ZTRMV
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
PREVLASTV = N
DO I = 1, K
PREVLASTV = MAX( PREVLASTV, I )
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = 1, I
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * CONJG( V( I , J ) )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i)
*
CALL ZGEMV( 'Conjugate transpose', J-I, I-1,
$ -TAU( I ), V( I+1, 1 ), LDV,
$ V( I+1, I ), 1, ONE, T( 1, I ), 1 )
ELSE
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * V( J , I )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H
*
CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ),
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV,
$ ONE, T( 1, I ), LDT )
END IF
*
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
*
CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
$ LDT, T( 1, I ), 1 )
T( I, I ) = TAU( I )
IF( I.GT.1 ) THEN
PREVLASTV = MAX( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
END DO
ELSE
PREVLASTV = 1
DO I = K, 1, -1
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = I, K
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( I.LT.K ) THEN
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i)
*
CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I,
$ -TAU( I ), V( J, I+1 ), LDV, V( J, I ),
$ 1, ONE, T( I+1, I ), 1 )
ELSE
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * V( J, N-K+I )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H
*
CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ),
$ V( I+1, J ), LDV, V( I, J ), LDV,
$ ONE, T( I+1, I ), LDT )
END IF
*
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
*
CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
IF( I.GT.1 ) THEN
PREVLASTV = MIN( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
T( I, I ) = TAU( I )
END IF
END DO
END IF
RETURN
*
* End of ZLARFT
*
END
piqp-octave/src/eigen/lapack/ilaclr.f 0000644 0001751 0000177 00000005665 14107270226 017416 0 ustar runner docker *> \brief \b ILACLR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILACLR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILACLR( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILACLR scans A for its last non-zero row.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complexOTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILACLR( M, N, A, LDA )
*
* -- LAPACK auxiliary 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
COMPLEX A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER ( ZERO = (0.0E+0, 0.0E+0) )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( M.EQ.0 ) THEN
ILACLR = M
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILACLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILACLR = 0
DO J = 1, N
I=M
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
I=I-1
ENDDO
ILACLR = MAX( ILACLR, I )
END DO
END IF
RETURN
END
piqp-octave/src/eigen/lapack/clarf.f 0000644 0001751 0000177 00000014227 14107270226 017231 0 ustar runner docker *> \brief \b CLARF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLARF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* COMPLEX TAU
* ..
* .. Array Arguments ..
* COMPLEX C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLARF applies a complex elementary reflector H to a complex M-by-N
*> matrix C, from either the left or the right. H is represented in the
*> form
*>
*> H = I - tau * v * v**H
*>
*> where tau is a complex scalar and v is a complex vector.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*>
*> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead
*> tau.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': form H * C
*> = 'R': form C * H
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX array, dimension
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
*> The vector v in the representation of H. V is not used if
*> TAU = 0.
*> \endverbatim
*>
*> \param[in] INCV
*> \verbatim
*> INCV is INTEGER
*> The increment between elements of v. INCV <> 0.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*> or C * H if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension
*> (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexOTHERauxiliary
*
* =====================================================================
SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary 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 SIDE
INTEGER INCV, LDC, M, N
COMPLEX TAU
* ..
* .. Array Arguments ..
COMPLEX C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE, ZERO
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ),
$ ZERO = ( 0.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL CGEMV, CGERC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILACLR, ILACLC
EXTERNAL LSAME, ILACLR, ILACLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 0
LASTC = 0
IF( TAU.NE.ZERO ) THEN
! Set up variables for scanning V. LASTV begins pointing to the end
! of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
! Look for the last non-zero row in V.
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
! Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILACLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILACLR(M, LASTV, C, LDC)
END IF
END IF
! Note that lastc.eq.0 renders the BLAS operations null; no special
! case is needed at this level.
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
*
CALL CGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
$ C, LDC, V, INCV, ZERO, WORK, 1 )
*
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
*
CALL CGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
CALL CGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
$ V, INCV, ZERO, WORK, 1 )
*
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
*
CALL CGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of CLARF
*
END
piqp-octave/src/eigen/lapack/ilazlr.f 0000644 0001751 0000177 00000005702 14107270226 017435 0 ustar runner docker *> \brief \b ILAZLR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILAZLR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILAZLR( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILAZLR scans A for its last non-zero row.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILAZLR( M, N, A, LDA )
*
* -- LAPACK auxiliary 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( M.EQ.0 ) THEN
ILAZLR = M
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILAZLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILAZLR = 0
DO J = 1, N
I=M
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
I=I-1
ENDDO
ILAZLR = MAX( ILAZLR, I )
END DO
END IF
RETURN
END
piqp-octave/src/eigen/lapack/iladlc.f 0000644 0001751 0000177 00000005610 14107270226 017366 0 ustar runner docker *> \brief \b ILADLC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILADLC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILADLC( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILADLC scans A for its last non-zero column.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILADLC( M, N, A, LDA )
*
* -- LAPACK auxiliary 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILADLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILADLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILADLC = N, 1, -1
DO I = 1, M
IF( A(I, ILADLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
piqp-octave/src/eigen/lapack/slarft.f 0000644 0001751 0000177 00000023707 14107270226 017440 0 ustar runner docker *> \brief \b SLARFT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLARFT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, STOREV
* INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
* REAL T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLARFT forms the triangular factor T of a real block reflector H
*> of order n, which is defined as a product of k elementary reflectors.
*>
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*>
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*>
*> If STOREV = 'C', the vector which defines the elementary reflector
*> H(i) is stored in the i-th column of the array V, and
*>
*> H = I - V * T * V**T
*>
*> If STOREV = 'R', the vector which defines the elementary reflector
*> H(i) is stored in the i-th row of the array V, and
*>
*> H = I - V**T * T * V
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Specifies the order in which the elementary reflectors are
*> multiplied to form the block reflector:
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Specifies how the vectors which define the elementary
*> reflectors are stored (see also Further Details):
*> = 'C': columnwise
*> = 'R': rowwise
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the block reflector H. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the triangular factor T (= the number of
*> elementary reflectors). K >= 1.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is REAL array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,N) if STOREV = 'R'
*> The matrix V. See further details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is REAL array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is REAL array, dimension (LDT,K)
*> The k by k triangular factor T of the block reflector.
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*> lower triangular. The rest of the array is not used.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup realOTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK auxiliary 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 DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
REAL T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, PREVLASTV, LASTV
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, STRMV
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
PREVLASTV = N
DO I = 1, K
PREVLASTV = MAX( I, PREVLASTV )
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = 1, I
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * V( I , J )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i)
*
CALL SGEMV( 'Transpose', J-I, I-1, -TAU( I ),
$ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE,
$ T( 1, I ), 1 )
ELSE
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * V( J , I )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T
*
CALL SGEMV( 'No transpose', I-1, J-I, -TAU( I ),
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV,
$ ONE, T( 1, I ), 1 )
END IF
*
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
*
CALL STRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
$ LDT, T( 1, I ), 1 )
T( I, I ) = TAU( I )
IF( I.GT.1 ) THEN
PREVLASTV = MAX( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
END DO
ELSE
PREVLASTV = 1
DO I = K, 1, -1
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = I, K
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( I.LT.K ) THEN
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * V( N-K+I , J )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i)
*
CALL SGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ),
$ V( J, I+1 ), LDV, V( J, I ), 1, ONE,
$ T( I+1, I ), 1 )
ELSE
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * V( J, N-K+I )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T
*
CALL SGEMV( 'No transpose', K-I, N-K+I-J,
$ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV,
$ ONE, T( I+1, I ), 1 )
END IF
*
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
*
CALL STRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
IF( I.GT.1 ) THEN
PREVLASTV = MIN( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
T( I, I ) = TAU( I )
END IF
END DO
END IF
RETURN
*
* End of SLARFT
*
END
piqp-octave/src/eigen/lapack/dlapy3.f 0000644 0001751 0000177 00000005261 14107270226 017334 0 ustar runner docker *> \brief \b DLAPY3
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAPY3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION X, Y, Z
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
*> unnecessary overflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION
*> X, Y and Z specify the values x, y and z.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
*
* -- LAPACK auxiliary 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 ..
DOUBLE PRECISION X, Y, Z
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION W, XABS, YABS, ZABS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
XABS = ABS( X )
YABS = ABS( Y )
ZABS = ABS( Z )
W = MAX( XABS, YABS, ZABS )
IF( W.EQ.ZERO ) THEN
* W can be zero for max(0,nan,0)
* adding all three entries together will make sure
* NaN will not disappear.
DLAPY3 = XABS + YABS + ZABS
ELSE
DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
$ ( ZABS / W )**2 )
END IF
RETURN
*
* End of DLAPY3
*
END
piqp-octave/src/eigen/lapack/second_NONE.f 0000644 0001751 0000177 00000002352 14107270226 020230 0 ustar runner docker *> \brief \b SECOND returns nothing
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* REAL FUNCTION SECOND( )
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SECOND returns nothing instead of returning the user time for a process in seconds.
*> If you are using that routine, it means that neither EXTERNAL ETIME,
*> EXTERNAL ETIME_, INTERNAL ETIME, INTERNAL CPU_TIME is available on
*> your machine.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
REAL FUNCTION SECOND( )
*
* -- LAPACK auxiliary 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
*
* =====================================================================
*
SECOND = 0.0E+0
RETURN
*
* End of SECOND
*
END
piqp-octave/src/eigen/lapack/double.cpp 0000644 0001751 0000177 00000001062 14107270226 017742 0 ustar runner docker // This file is part of Eigen, a lightweight C++ template library
// for linear algebra.
//
// Copyright (C) 2009-2014 Gael Guennebaud
//
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
#define SCALAR double
#define SCALAR_SUFFIX d
#define SCALAR_SUFFIX_UP "D"
#define ISCOMPLEX 0
#include "cholesky.cpp"
#include "lu.cpp"
#include "eigenvalues.cpp"
#include "svd.cpp"
piqp-octave/src/eigen/lapack/single.cpp 0000644 0001751 0000177 00000001061 14107270226 017750 0 ustar runner docker // This file is part of Eigen, a lightweight C++ template library
// for linear algebra.
//
// Copyright (C) 2009-2014 Gael Guennebaud
//
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
#define SCALAR float
#define SCALAR_SUFFIX s
#define SCALAR_SUFFIX_UP "S"
#define ISCOMPLEX 0
#include "cholesky.cpp"
#include "lu.cpp"
#include "eigenvalues.cpp"
#include "svd.cpp"
piqp-octave/src/eigen/lapack/dladiv.f 0000644 0001751 0000177 00000005631 14107270226 017404 0 ustar runner docker *> \brief \b DLADIV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION A, B, C, D, P, Q
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLADIV performs complex division in real arithmetic
*>
*> a + i*b
*> 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
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is DOUBLE PRECISION
*> The scalars a, b, c, and d in the above expression.
*> \endverbatim
*>
*> \param[out] P
*> \verbatim
*> P is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is DOUBLE PRECISION
*> The scalars p and q in the above expression.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary 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 ..
DOUBLE PRECISION A, B, C, D, P, Q
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION E, F
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. 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
END IF
*
RETURN
*
* End of DLADIV
*
END
piqp-octave/src/eigen/lapack/dlamch.f 0000644 0001751 0000177 00000012213 14107270226 017363 0 ustar runner docker *> \brief \b DLAMCH
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAMCH determines double precision machine parameters.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] CMACH
*> \verbatim
*> Specifies the value to be returned by DLAMCH:
*> = 'E' or 'e', DLAMCH := eps
*> = 'S' or 's , DLAMCH := sfmin
*> = 'B' or 'b', DLAMCH := base
*> = 'P' or 'p', DLAMCH := eps*base
*> = 'N' or 'n', DLAMCH := t
*> = 'R' or 'r', DLAMCH := rnd
*> = 'M' or 'm', DLAMCH := emin
*> = 'U' or 'u', DLAMCH := rmin
*> = 'L' or 'l', DLAMCH := emax
*> = 'O' or 'o', DLAMCH := rmax
*> where
*> eps = relative machine precision
*> sfmin = safe minimum, such that 1/sfmin does not overflow
*> base = base of the machine
*> prec = eps*base
*> t = number of (base) digits in the mantissa
*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
*> emin = minimum exponent before (gradual) underflow
*> rmin = underflow threshold - base**(emin-1)
*> emax = largest exponent before overflow
*> rmax = overflow threshold - (base**emax)*(1-eps)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
* -- LAPACK auxiliary 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 CMACH
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT,
$ MINEXPONENT, RADIX, TINY
* ..
* .. Executable Statements ..
*
*
* Assume rounding, not chopping. Always.
*
RND = ONE
*
IF( ONE.EQ.RND ) THEN
EPS = EPSILON(ZERO) * 0.5
ELSE
EPS = EPSILON(ZERO)
END IF
*
IF( LSAME( CMACH, 'E' ) ) THEN
RMACH = EPS
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
SFMIN = TINY(ZERO)
SMALL = ONE / HUGE(ZERO)
IF( SMALL.GE.SFMIN ) THEN
*
* Use SMALL plus a bit, to avoid the possibility of rounding
* causing overflow when computing 1/sfmin.
*
SFMIN = SMALL*( ONE+EPS )
END IF
RMACH = SFMIN
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
RMACH = RADIX(ZERO)
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
RMACH = EPS * RADIX(ZERO)
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
RMACH = DIGITS(ZERO)
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
RMACH = RND
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
RMACH = MINEXPONENT(ZERO)
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
RMACH = tiny(zero)
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
RMACH = MAXEXPONENT(ZERO)
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
RMACH = HUGE(ZERO)
ELSE
RMACH = ZERO
END IF
*
DLAMCH = RMACH
RETURN
*
* End of DLAMCH
*
END
************************************************************************
*> \brief \b DLAMC3
*> \details
*> \b Purpose:
*> \verbatim
*> DLAMC3 is intended to force A and B to be stored prior to doing
*> the addition of A and B , for use in situations where optimizers
*> might hold one of these in a register.
*> \endverbatim
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
*> \date November 2011
*> \ingroup auxOTHERauxiliary
*>
*> \param[in] A
*> \verbatim
*> A is a DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is a DOUBLE PRECISION
*> The values A and B.
*> \endverbatim
*>
DOUBLE PRECISION FUNCTION DLAMC3( A, B )
*
* -- LAPACK auxiliary routine (version 3.4.0) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2010
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B
* ..
* =====================================================================
*
* .. Executable Statements ..
*
DLAMC3 = A + B
*
RETURN
*
* End of DLAMC3
*
END
*
************************************************************************
piqp-octave/src/eigen/lapack/cholesky.cpp 0000644 0001751 0000177 00000004235 14107270226 020316 0 ustar runner docker // This file is part of Eigen, a lightweight C++ template library
// for linear algebra.
//
// Copyright (C) 2010-2011 Gael Guennebaud
//
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
#include "lapack_common.h"
#include
// POTRF computes the Cholesky factorization of a real symmetric positive definite matrix A.
EIGEN_LAPACK_FUNC(potrf,(char* uplo, int *n, RealScalar *pa, int *lda, int *info))
{
*info = 0;
if(UPLO(*uplo)==INVALID) *info = -1;
else if(*n<0) *info = -2;
else if(*lda(pa);
MatrixType A(a,*n,*n,*lda);
int ret;
if(UPLO(*uplo)==UP) ret = int(internal::llt_inplace::blocked(A));
else ret = int(internal::llt_inplace::blocked(A));
if(ret>=0)
*info = ret+1;
return 0;
}
// POTRS solves a system of linear equations A*X = B with a symmetric
// positive definite matrix A using the Cholesky factorization
// A = U**T*U or A = L*L**T computed by DPOTRF.
EIGEN_LAPACK_FUNC(potrs,(char* uplo, int *n, int *nrhs, RealScalar *pa, int *lda, RealScalar *pb, int *ldb, int *info))
{
*info = 0;
if(UPLO(*uplo)==INVALID) *info = -1;
else if(*n<0) *info = -2;
else if(*nrhs<0) *info = -3;
else if(*lda(pa);
Scalar* b = reinterpret_cast(pb);
MatrixType A(a,*n,*n,*lda);
MatrixType B(b,*n,*nrhs,*ldb);
if(UPLO(*uplo)==UP)
{
A.triangularView().adjoint().solveInPlace(B);
A.triangularView().solveInPlace(B);
}
else
{
A.triangularView().solveInPlace(B);
A.triangularView().adjoint().solveInPlace(B);
}
return 0;
}
piqp-octave/src/eigen/lapack/slarfb.f 0000644 0001751 0000177 00000054307 14107270226 017416 0 ustar runner docker *> \brief \b SLARFB
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLARFB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
* T, LDT, C, LDC, WORK, LDWORK )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, SIDE, STOREV, TRANS
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
* REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
* $ WORK( LDWORK, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLARFB applies a real block reflector H or its transpose H**T to a
*> real m by n matrix C, from either the left or the right.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply H or H**T from the Left
*> = 'R': apply H or H**T from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply H (No transpose)
*> = 'T': apply H**T (Transpose)
*> \endverbatim
*>
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Indicates how H is formed from a product of elementary
*> reflectors
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Indicates how the vectors which define the elementary
*> reflectors are stored:
*> = 'C': Columnwise
*> = 'R': Rowwise
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the matrix T (= the number of elementary
*> reflectors whose product defines the block reflector).
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is REAL array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
*> The matrix V. See Further Details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
*> if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] T
*> \verbatim
*> T is REAL array, dimension (LDT,K)
*> The triangular k by k matrix T in the representation of the
*> block reflector.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is REAL array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is REAL array, dimension (LDWORK,K)
*> \endverbatim
*>
*> \param[in] LDWORK
*> \verbatim
*> LDWORK is INTEGER
*> The leading dimension of the array WORK.
*> If SIDE = 'L', LDWORK >= max(1,N);
*> if SIDE = 'R', LDWORK >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup realOTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored; the corresponding
*> array elements are modified but restored on exit. The rest of the
*> array is not used.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK auxiliary 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 DIRECT, SIDE, STOREV, TRANS
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J, LASTV, LASTC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILASLR, ILASLC
EXTERNAL LSAME, ILASLR, ILASLC
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, STRMM
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
IF( LSAME( STOREV, 'C' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 ) (first K rows)
* ( V2 )
* where V1 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILASLR( M, K, V, LDV ) )
LASTC = ILASLC( 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 SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2**T *V2
*
CALL SGEMM( 'Transpose', 'No transpose',
$ LASTC, K, LASTV-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 STRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**T
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - V2 * W**T
*
CALL SGEMM( 'No transpose', 'Transpose',
$ LASTV-K, LASTC, K,
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**T
*
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 30 J = 1, K
DO 20 I = 1, LASTC
C( J, I ) = C( J, I ) - WORK( I, J )
20 CONTINUE
30 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
*
LASTV = MAX( K, ILASLR( N, K, V, LDV ) )
LASTC = ILASLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL SGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-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 STRMM( 'Right', 'Upper', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**T
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - W * V2**T
*
CALL SGEMM( 'No transpose', 'Transpose',
$ LASTC, LASTV-K, K,
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**T
*
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, LASTC
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
ELSE
*
* Let V = ( V1 )
* ( V2 ) (last K rows)
* where V2 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILASLR( M, K, V, LDV ) )
LASTC = ILASLC( LASTV, 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 SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1**T*V1
*
CALL SGEMM( 'Transpose', 'No transpose',
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**T
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1 * W**T
*
CALL SGEMM( 'No transpose', 'Transpose',
$ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
END IF
*
* W := W * V2**T
*
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 90 J = 1, K
DO 80 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J)
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
*
LASTV = MAX( K, ILASLR( N, K, V, LDV ) )
LASTC = ILASLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL SCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL SGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**T
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1**T
*
CALL SGEMM( 'No transpose', 'Transpose',
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
END IF
*
* W := W * V2**T
*
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
110 CONTINUE
120 CONTINUE
END IF
END IF
*
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 V2 ) (V1: first K columns)
* where V1 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILASLC( K, M, V, LDV ) )
LASTC = ILASLC( 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 SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**T
*
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2**T*V2**T
*
CALL SGEMM( 'Transpose', 'Transpose',
$ LASTC, K, LASTV-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 STRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - V2**T * W**T
*
CALL SGEMM( 'Transpose', 'Transpose',
$ LASTV-K, LASTC, K,
$ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
$ ONE, C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 150 J = 1, K
DO 140 I = 1, LASTC
C( J, I ) = C( J, I ) - WORK( I, J )
140 CONTINUE
150 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
*
LASTV = MAX( K, ILASLC( K, N, V, LDV ) )
LASTC = ILASLR( 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 SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**T
*
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2**T
*
CALL SGEMM( 'No transpose', 'Transpose',
$ LASTC, K, LASTV-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 STRMM( 'Right', 'Upper', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL SGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
$ ONE, C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, LASTC
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
*
END IF
*
ELSE
*
* Let V = ( V1 V2 ) (V2: last K columns)
* where V2 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**T * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILASLC( K, M, V, LDV ) )
LASTC = ILASLC( LASTV, 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 SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**T
*
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1**T * V1**T
*
CALL SGEMM( 'Transpose', 'Transpose',
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1**T * W**T
*
CALL SGEMM( 'Transpose', 'Transpose',
$ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 210 J = 1, K
DO 200 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-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 )
*
LASTV = MAX( K, ILASLC( K, N, V, LDV ) )
LASTC = ILASLR( M, LASTV, C, LDC )
*
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL SCOPY( LASTC, C( 1, LASTV-K+J ), 1,
$ WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**T
*
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1**T
*
CALL SGEMM( 'No transpose', 'Transpose',
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL SGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
$ - WORK( I, J )
230 CONTINUE
240 CONTINUE
*
END IF
*
END IF
END IF
*
RETURN
*
* End of SLARFB
*
END
piqp-octave/src/eigen/lapack/clacgv.f 0000644 0001751 0000177 00000005417 14107270226 017402 0 ustar runner docker *> \brief \b CLACGV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLACGV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLACGV( N, X, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* ..
* .. Array Arguments ..
* COMPLEX X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLACGV conjugates a complex vector of length N.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The length of the vector X. N >= 0.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, dimension
*> (1+(N-1)*abs(INCX))
*> On entry, the vector of length N to be conjugated.
*> On exit, X is overwritten with conjg(X).
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The spacing between successive elements of X.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexOTHERauxiliary
*
* =====================================================================
SUBROUTINE CLACGV( N, X, INCX )
*
* -- LAPACK auxiliary 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 ..
INTEGER INCX, N
* ..
* .. Array Arguments ..
COMPLEX X( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IOFF
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG
* ..
* .. Executable Statements ..
*
IF( INCX.EQ.1 ) THEN
DO 10 I = 1, N
X( I ) = CONJG( X( I ) )
10 CONTINUE
ELSE
IOFF = 1
IF( INCX.LT.0 )
$ IOFF = 1 - ( N-1 )*INCX
DO 20 I = 1, N
X( IOFF ) = CONJG( X( IOFF ) )
IOFF = IOFF + INCX
20 CONTINUE
END IF
RETURN
*
* End of CLACGV
*
END
piqp-octave/src/eigen/lapack/eigenvalues.cpp 0000644 0001751 0000177 00000003442 14107270226 021003 0 ustar runner docker // This file is part of Eigen, a lightweight C++ template library
// for linear algebra.
//
// Copyright (C) 2011 Gael Guennebaud
//
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
#include "lapack_common.h"
#include
// computes eigen values and vectors of a general N-by-N matrix A
EIGEN_LAPACK_FUNC(syev,(char *jobz, char *uplo, int* n, Scalar* a, int *lda, Scalar* w, Scalar* /*work*/, int* lwork, int *info))
{
// TODO exploit the work buffer
bool query_size = *lwork==-1;
*info = 0;
if(*jobz!='N' && *jobz!='V') *info = -1;
else if(UPLO(*uplo)==INVALID) *info = -2;
else if(*n<0) *info = -3;
else if(*lda eig(mat,computeVectors?ComputeEigenvectors:EigenvaluesOnly);
if(eig.info()==NoConvergence)
{
make_vector(w,*n).setZero();
if(computeVectors)
matrix(a,*n,*n,*lda).setIdentity();
//*info = 1;
return 0;
}
make_vector(w,*n) = eig.eigenvalues();
if(computeVectors)
matrix(a,*n,*n,*lda) = eig.eigenvectors();
return 0;
}
piqp-octave/src/eigen/lapack/dlarft.f 0000644 0001751 0000177 00000023756 14107270226 017425 0 ustar runner docker *> \brief \b DLARFT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARFT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, STOREV
* INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARFT forms the triangular factor T of a real block reflector H
*> of order n, which is defined as a product of k elementary reflectors.
*>
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*>
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*>
*> If STOREV = 'C', the vector which defines the elementary reflector
*> H(i) is stored in the i-th column of the array V, and
*>
*> H = I - V * T * V**T
*>
*> If STOREV = 'R', the vector which defines the elementary reflector
*> H(i) is stored in the i-th row of the array V, and
*>
*> H = I - V**T * T * V
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Specifies the order in which the elementary reflectors are
*> multiplied to form the block reflector:
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Specifies how the vectors which define the elementary
*> reflectors are stored (see also Further Details):
*> = 'C': columnwise
*> = 'R': rowwise
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the block reflector H. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the triangular factor T (= the number of
*> elementary reflectors). K >= 1.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is DOUBLE PRECISION array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,N) if STOREV = 'R'
*> The matrix V. See further details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is DOUBLE PRECISION array, dimension (LDT,K)
*> The k by k triangular factor T of the block reflector.
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*> lower triangular. The rest of the array is not used.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup doubleOTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK auxiliary 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 DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, PREVLASTV, LASTV
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DTRMV
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
PREVLASTV = N
DO I = 1, K
PREVLASTV = MAX( I, PREVLASTV )
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = 1, I
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * V( I , J )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i)
*
CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ),
$ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE,
$ T( 1, I ), 1 )
ELSE
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * V( J , I )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T
*
CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ),
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE,
$ T( 1, I ), 1 )
END IF
*
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
*
CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
$ LDT, T( 1, I ), 1 )
T( I, I ) = TAU( I )
IF( I.GT.1 ) THEN
PREVLASTV = MAX( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
END DO
ELSE
PREVLASTV = 1
DO I = K, 1, -1
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = I, K
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( I.LT.K ) THEN
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * V( N-K+I , J )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i)
*
CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ),
$ V( J, I+1 ), LDV, V( J, I ), 1, ONE,
$ T( I+1, I ), 1 )
ELSE
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * V( J, N-K+I )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T
*
CALL DGEMV( 'No transpose', K-I, N-K+I-J,
$ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV,
$ ONE, T( I+1, I ), 1 )
END IF
*
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
*
CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
IF( I.GT.1 ) THEN
PREVLASTV = MIN( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
T( I, I ) = TAU( I )
END IF
END DO
END IF
RETURN
*
* End of DLARFT
*
END
piqp-octave/src/eigen/lapack/CMakeLists.txt 0000644 0001751 0000177 00000025174 14107270226 020536 0 ustar runner docker
project(EigenLapack CXX)
include(CheckLanguage)
check_language(Fortran)
if(CMAKE_Fortran_COMPILER)
enable_language(Fortran)
set(EIGEN_Fortran_COMPILER_WORKS ON)
else()
set(EIGEN_Fortran_COMPILER_WORKS OFF)
endif()
add_custom_target(lapack)
include_directories(../blas)
set(EigenLapack_SRCS
single.cpp double.cpp complex_single.cpp complex_double.cpp ../blas/xerbla.cpp
)
if(EIGEN_Fortran_COMPILER_WORKS)
set(EigenLapack_SRCS ${EigenLapack_SRCS}
slarft.f dlarft.f clarft.f zlarft.f
slarfb.f dlarfb.f clarfb.f zlarfb.f
slarfg.f dlarfg.f clarfg.f zlarfg.f
slarf.f dlarf.f clarf.f zlarf.f
sladiv.f dladiv.f cladiv.f zladiv.f
ilaslr.f iladlr.f ilaclr.f ilazlr.f
ilaslc.f iladlc.f ilaclc.f ilazlc.f
dlapy2.f dlapy3.f slapy2.f slapy3.f
clacgv.f zlacgv.f
slamch.f dlamch.f
second_NONE.f dsecnd_NONE.f
)
option(EIGEN_ENABLE_LAPACK_TESTS OFF "Enable the Lapack unit tests")
if(EIGEN_ENABLE_LAPACK_TESTS)
get_filename_component(eigen_full_path_to_reference_lapack "./reference/" ABSOLUTE)
if(NOT EXISTS ${eigen_full_path_to_reference_lapack})
# Download lapack and install sources and testing at the right place
message(STATUS "Download lapack_addons_3.4.1.tgz...")
file(DOWNLOAD "http://downloads.tuxfamily.org/eigen/lapack_addons_3.4.1.tgz"
"${CMAKE_CURRENT_SOURCE_DIR}/lapack_addons_3.4.1.tgz"
INACTIVITY_TIMEOUT 15
TIMEOUT 240
STATUS download_status
EXPECTED_MD5 ab5742640617e3221a873aba44bbdc93
SHOW_PROGRESS)
message(STATUS ${download_status})
list(GET download_status 0 download_status_num)
set(download_status_num 0)
if(download_status_num EQUAL 0)
message(STATUS "Setup lapack reference and lapack unit tests")
execute_process(COMMAND tar xzf "lapack_addons_3.4.1.tgz" WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
else()
message(STATUS "Download of lapack_addons_3.4.1.tgz failed, LAPACK unit tests won't be enabled")
set(EIGEN_ENABLE_LAPACK_TESTS false)
endif()
endif()
get_filename_component(eigen_full_path_to_reference_lapack "./reference/" ABSOLUTE)
if(EXISTS ${eigen_full_path_to_reference_lapack})
set(EigenLapack_funcfilenames
ssyev.f dsyev.f csyev.f zsyev.f
spotrf.f dpotrf.f cpotrf.f zpotrf.f
spotrs.f dpotrs.f cpotrs.f zpotrs.f
sgetrf.f dgetrf.f cgetrf.f zgetrf.f
sgetrs.f dgetrs.f cgetrs.f zgetrs.f)
file(GLOB ReferenceLapack_SRCS0 RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} "reference/*.f")
foreach(filename1 IN LISTS ReferenceLapack_SRCS0)
string(REPLACE "reference/" "" filename ${filename1})
list(FIND EigenLapack_SRCS ${filename} id1)
list(FIND EigenLapack_funcfilenames ${filename} id2)
if((id1 EQUAL -1) AND (id2 EQUAL -1))
set(ReferenceLapack_SRCS ${ReferenceLapack_SRCS} reference/${filename})
endif()
endforeach()
endif()
endif()
endif()
set(EIGEN_LAPACK_TARGETS "")
add_library(eigen_lapack_static ${EigenLapack_SRCS} ${ReferenceLapack_SRCS})
list(APPEND EIGEN_LAPACK_TARGETS eigen_lapack_static)
if (EIGEN_BUILD_SHARED_LIBS)
add_library(eigen_lapack SHARED ${EigenLapack_SRCS})
list(APPEND EIGEN_LAPACK_TARGETS eigen_lapack)
target_link_libraries(eigen_lapack eigen_blas)
endif()
foreach(target IN LISTS EIGEN_LAPACK_TARGETS)
if(EIGEN_STANDARD_LIBRARIES_TO_LINK_TO)
target_link_libraries(${target} ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO})
endif()
add_dependencies(lapack ${target})
install(TARGETS ${target}
RUNTIME DESTINATION bin
LIBRARY DESTINATION lib
ARCHIVE DESTINATION lib)
endforeach()
get_filename_component(eigen_full_path_to_testing_lapack "./testing/" ABSOLUTE)
if(EXISTS ${eigen_full_path_to_testing_lapack})
# The following comes from lapack/TESTING/CMakeLists.txt
# Get Python
find_package(PythonInterp)
message(STATUS "Looking for Python found - ${PYTHONINTERP_FOUND}")
if (PYTHONINTERP_FOUND)
message(STATUS "Using Python version ${PYTHON_VERSION_STRING}")
endif()
set(LAPACK_SOURCE_DIR ${CMAKE_CURRENT_SOURCE_DIR})
set(LAPACK_BINARY_DIR ${CMAKE_CURRENT_BINARY_DIR})
set(BUILD_SINGLE true)
set(BUILD_DOUBLE true)
set(BUILD_COMPLEX true)
set(BUILD_COMPLEX16E true)
if(MSVC_VERSION)
# string(REPLACE "/STACK:10000000" "/STACK:900000000000000000"
# CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS}")
string(REGEX REPLACE "(.*)/STACK:(.*) (.*)" "\\1/STACK:900000000000000000 \\3"
CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS}")
endif()
file(MAKE_DIRECTORY "${LAPACK_BINARY_DIR}/TESTING")
add_subdirectory(testing/MATGEN)
add_subdirectory(testing/LIN)
add_subdirectory(testing/EIG)
macro(add_lapack_test output input target)
set(TEST_INPUT "${LAPACK_SOURCE_DIR}/testing/${input}")
set(TEST_OUTPUT "${LAPACK_BINARY_DIR}/TESTING/${output}")
string(REPLACE "." "_" input_name ${input})
set(testName "${target}_${input_name}")
if(EXISTS "${TEST_INPUT}")
add_test(NAME LAPACK-${testName}
COMMAND "${CMAKE_COMMAND}"
-DTEST=$
-DINPUT=${TEST_INPUT}
-DOUTPUT=${TEST_OUTPUT}
-DINTDIR=${CMAKE_CFG_INTDIR}
-P "${LAPACK_SOURCE_DIR}/testing/runtest.cmake")
endif()
endmacro()
if (BUILD_SINGLE)
add_lapack_test(stest.out stest.in xlintsts)
#
# ======== SINGLE RFP LIN TESTS ========================
add_lapack_test(stest_rfp.out stest_rfp.in xlintstrfs)
#
#
# ======== SINGLE EIG TESTS ===========================
#
add_lapack_test(snep.out nep.in xeigtsts)
add_lapack_test(ssep.out sep.in xeigtsts)
add_lapack_test(ssvd.out svd.in xeigtsts)
add_lapack_test(sec.out sec.in xeigtsts)
add_lapack_test(sed.out sed.in xeigtsts)
add_lapack_test(sgg.out sgg.in xeigtsts)
add_lapack_test(sgd.out sgd.in xeigtsts)
add_lapack_test(ssb.out ssb.in xeigtsts)
add_lapack_test(ssg.out ssg.in xeigtsts)
add_lapack_test(sbal.out sbal.in xeigtsts)
add_lapack_test(sbak.out sbak.in xeigtsts)
add_lapack_test(sgbal.out sgbal.in xeigtsts)
add_lapack_test(sgbak.out sgbak.in xeigtsts)
add_lapack_test(sbb.out sbb.in xeigtsts)
add_lapack_test(sglm.out glm.in xeigtsts)
add_lapack_test(sgqr.out gqr.in xeigtsts)
add_lapack_test(sgsv.out gsv.in xeigtsts)
add_lapack_test(scsd.out csd.in xeigtsts)
add_lapack_test(slse.out lse.in xeigtsts)
endif()
if (BUILD_DOUBLE)
#
# ======== DOUBLE LIN TESTS ===========================
add_lapack_test(dtest.out dtest.in xlintstd)
#
# ======== DOUBLE RFP LIN TESTS ========================
add_lapack_test(dtest_rfp.out dtest_rfp.in xlintstrfd)
#
# ======== DOUBLE EIG TESTS ===========================
add_lapack_test(dnep.out nep.in xeigtstd)
add_lapack_test(dsep.out sep.in xeigtstd)
add_lapack_test(dsvd.out svd.in xeigtstd)
add_lapack_test(dec.out dec.in xeigtstd)
add_lapack_test(ded.out ded.in xeigtstd)
add_lapack_test(dgg.out dgg.in xeigtstd)
add_lapack_test(dgd.out dgd.in xeigtstd)
add_lapack_test(dsb.out dsb.in xeigtstd)
add_lapack_test(dsg.out dsg.in xeigtstd)
add_lapack_test(dbal.out dbal.in xeigtstd)
add_lapack_test(dbak.out dbak.in xeigtstd)
add_lapack_test(dgbal.out dgbal.in xeigtstd)
add_lapack_test(dgbak.out dgbak.in xeigtstd)
add_lapack_test(dbb.out dbb.in xeigtstd)
add_lapack_test(dglm.out glm.in xeigtstd)
add_lapack_test(dgqr.out gqr.in xeigtstd)
add_lapack_test(dgsv.out gsv.in xeigtstd)
add_lapack_test(dcsd.out csd.in xeigtstd)
add_lapack_test(dlse.out lse.in xeigtstd)
endif()
if (BUILD_COMPLEX)
add_lapack_test(ctest.out ctest.in xlintstc)
#
# ======== COMPLEX RFP LIN TESTS ========================
add_lapack_test(ctest_rfp.out ctest_rfp.in xlintstrfc)
#
# ======== COMPLEX EIG TESTS ===========================
add_lapack_test(cnep.out nep.in xeigtstc)
add_lapack_test(csep.out sep.in xeigtstc)
add_lapack_test(csvd.out svd.in xeigtstc)
add_lapack_test(cec.out cec.in xeigtstc)
add_lapack_test(ced.out ced.in xeigtstc)
add_lapack_test(cgg.out cgg.in xeigtstc)
add_lapack_test(cgd.out cgd.in xeigtstc)
add_lapack_test(csb.out csb.in xeigtstc)
add_lapack_test(csg.out csg.in xeigtstc)
add_lapack_test(cbal.out cbal.in xeigtstc)
add_lapack_test(cbak.out cbak.in xeigtstc)
add_lapack_test(cgbal.out cgbal.in xeigtstc)
add_lapack_test(cgbak.out cgbak.in xeigtstc)
add_lapack_test(cbb.out cbb.in xeigtstc)
add_lapack_test(cglm.out glm.in xeigtstc)
add_lapack_test(cgqr.out gqr.in xeigtstc)
add_lapack_test(cgsv.out gsv.in xeigtstc)
add_lapack_test(ccsd.out csd.in xeigtstc)
add_lapack_test(clse.out lse.in xeigtstc)
endif()
if (BUILD_COMPLEX16)
#
# ======== COMPLEX16 LIN TESTS ========================
add_lapack_test(ztest.out ztest.in xlintstz)
#
# ======== COMPLEX16 RFP LIN TESTS ========================
add_lapack_test(ztest_rfp.out ztest_rfp.in xlintstrfz)
#
# ======== COMPLEX16 EIG TESTS ===========================
add_lapack_test(znep.out nep.in xeigtstz)
add_lapack_test(zsep.out sep.in xeigtstz)
add_lapack_test(zsvd.out svd.in xeigtstz)
add_lapack_test(zec.out zec.in xeigtstz)
add_lapack_test(zed.out zed.in xeigtstz)
add_lapack_test(zgg.out zgg.in xeigtstz)
add_lapack_test(zgd.out zgd.in xeigtstz)
add_lapack_test(zsb.out zsb.in xeigtstz)
add_lapack_test(zsg.out zsg.in xeigtstz)
add_lapack_test(zbal.out zbal.in xeigtstz)
add_lapack_test(zbak.out zbak.in xeigtstz)
add_lapack_test(zgbal.out zgbal.in xeigtstz)
add_lapack_test(zgbak.out zgbak.in xeigtstz)
add_lapack_test(zbb.out zbb.in xeigtstz)
add_lapack_test(zglm.out glm.in xeigtstz)
add_lapack_test(zgqr.out gqr.in xeigtstz)
add_lapack_test(zgsv.out gsv.in xeigtstz)
add_lapack_test(zcsd.out csd.in xeigtstz)
add_lapack_test(zlse.out lse.in xeigtstz)
endif()
if (BUILD_SIMPLE)
if (BUILD_DOUBLE)
#
# ======== SINGLE-DOUBLE PROTO LIN TESTS ==============
add_lapack_test(dstest.out dstest.in xlintstds)
endif()
endif()
if (BUILD_COMPLEX)
if (BUILD_COMPLEX16)
#
# ======== COMPLEX-COMPLEX16 LIN TESTS ========================
add_lapack_test(zctest.out zctest.in xlintstzc)
endif()
endif()
# ==============================================================================
execute_process(COMMAND ${CMAKE_COMMAND} -E copy ${LAPACK_SOURCE_DIR}/testing/lapack_testing.py ${LAPACK_BINARY_DIR})
add_test(
NAME LAPACK_Test_Summary
WORKING_DIRECTORY ${LAPACK_BINARY_DIR}
COMMAND ${PYTHON_EXECUTABLE} "lapack_testing.py"
)
endif()
piqp-octave/src/eigen/lapack/dlarfg.f 0000644 0001751 0000177 00000011522 14107270226 017374 0 ustar runner docker *> \brief \b DLARFG
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARFG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* DOUBLE PRECISION ALPHA, TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARFG generates a real elementary reflector H of order n, such
*> that
*>
*> H * ( alpha ) = ( beta ), H**T * H = I.
*> ( x ) ( 0 )
*>
*> where alpha and beta are scalars, and x is an (n-1)-element real
*> vector. H is represented in the form
*>
*> H = I - tau * ( 1 ) * ( 1 v**T ) ,
*> ( v )
*>
*> where tau is a real scalar and v is a real (n-1)-element
*> vector.
*>
*> If the elements of x are all zero, then tau = 0 and H is taken to be
*> the unit matrix.
*>
*> Otherwise 1 <= tau <= 2.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the elementary reflector.
*> \endverbatim
*>
*> \param[in,out] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION
*> On entry, the value alpha.
*> On exit, it is overwritten with the value beta.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension
*> (1+(N-2)*abs(INCX))
*> On entry, the vector x.
*> On exit, it is overwritten with the vector v.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between elements of X. INCX > 0.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION
*> The value tau.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup doubleOTHERauxiliary
*
* =====================================================================
SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary 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 ..
INTEGER INCX, N
DOUBLE PRECISION ALPHA, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
EXTERNAL DLAMCH, DLAPY2, DNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN
* ..
* .. External Subroutines ..
EXTERNAL DSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.1 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = DNRM2( N-1, X, INCX )
*
IF( XNORM.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
RSAFMN = ONE / SAFMIN
10 CONTINUE
KNT = KNT + 1
CALL DSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHA = ALPHA*RSAFMN
IF( ABS( BETA ).LT.SAFMIN )
$ GO TO 10
*
* New BETA is at most 1, at least SAFMIN
*
XNORM = DNRM2( N-1, X, INCX )
BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
END IF
TAU = ( BETA-ALPHA ) / BETA
CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
DO 20 J = 1, KNT
BETA = BETA*SAFMIN
20 CONTINUE
ALPHA = BETA
END IF
*
RETURN
*
* End of DLARFG
*
END
piqp-octave/src/eigen/lapack/slarf.f 0000644 0001751 0000177 00000013745 14107270226 017255 0 ustar runner docker *> \brief \b SLARF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLARF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* REAL TAU
* ..
* .. Array Arguments ..
* REAL C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLARF applies a real elementary reflector H to a real m by n matrix
*> C, from either the left or the right. H is represented in the form
*>
*> H = I - tau * v * v**T
*>
*> where tau is a real scalar and v is a real vector.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': form H * C
*> = 'R': form C * H
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is REAL array, dimension
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
*> The vector v in the representation of H. V is not used if
*> TAU = 0.
*> \endverbatim
*>
*> \param[in] INCV
*> \verbatim
*> INCV is INTEGER
*> The increment between elements of v. INCV <> 0.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is REAL
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is REAL array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*> or C * H if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is REAL array, dimension
*> (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup realOTHERauxiliary
*
* =====================================================================
SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary 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 SIDE
INTEGER INCV, LDC, M, N
REAL TAU
* ..
* .. Array Arguments ..
REAL C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILASLR, ILASLC
EXTERNAL LSAME, ILASLR, ILASLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 0
LASTC = 0
IF( TAU.NE.ZERO ) THEN
! Set up variables for scanning V. LASTV begins pointing to the end
! of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
! Look for the last non-zero row in V.
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
! Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILASLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILASLR(M, LASTV, C, LDC)
END IF
END IF
! Note that lastc.eq.0 renders the BLAS operations null; no special
! case is needed at this level.
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
*
CALL SGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
$ ZERO, WORK, 1 )
*
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T
*
CALL SGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
CALL SGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
$ V, INCV, ZERO, WORK, 1 )
*
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T
*
CALL SGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of SLARF
*
END
piqp-octave/src/eigen/lapack/lapack_common.h 0000644 0001751 0000177 00000001555 14107270226 020747 0 ustar runner docker // This file is part of Eigen, a lightweight C++ template library
// for linear algebra.
//
// Copyright (C) 2010-2014 Gael Guennebaud
//
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
#ifndef EIGEN_LAPACK_COMMON_H
#define EIGEN_LAPACK_COMMON_H
#include "../blas/common.h"
#include "../Eigen/src/misc/lapack.h"
#define EIGEN_LAPACK_FUNC(FUNC,ARGLIST) \
extern "C" { int EIGEN_BLAS_FUNC(FUNC) ARGLIST; } \
int EIGEN_BLAS_FUNC(FUNC) ARGLIST
typedef Eigen::Map > PivotsType;
#if ISCOMPLEX
#define EIGEN_LAPACK_ARG_IF_COMPLEX(X) X,
#else
#define EIGEN_LAPACK_ARG_IF_COMPLEX(X)
#endif
#endif // EIGEN_LAPACK_COMMON_H
piqp-octave/src/eigen/lapack/svd.cpp 0000644 0001751 0000177 00000011433 14107270226 017267 0 ustar runner docker // This file is part of Eigen, a lightweight C++ template library
// for linear algebra.
//
// Copyright (C) 2014 Gael Guennebaud
//
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
#include "lapack_common.h"
#include
// computes the singular values/vectors a general M-by-N matrix A using divide-and-conquer
EIGEN_LAPACK_FUNC(gesdd,(char *jobz, int *m, int* n, Scalar* a, int *lda, RealScalar *s, Scalar *u, int *ldu, Scalar *vt, int *ldvt, Scalar* /*work*/, int* lwork,
EIGEN_LAPACK_ARG_IF_COMPLEX(RealScalar */*rwork*/) int * /*iwork*/, int *info))
{
// TODO exploit the work buffer
bool query_size = *lwork==-1;
int diag_size = (std::min)(*m,*n);
*info = 0;
if(*jobz!='A' && *jobz!='S' && *jobz!='O' && *jobz!='N') *info = -1;
else if(*m<0) *info = -2;
else if(*n<0) *info = -3;
else if(*lda=*n && *ldvt<*n)) *info = -10;
if(*info!=0)
{
int e = -*info;
return xerbla_(SCALAR_SUFFIX_UP"GESDD ", &e, 6);
}
if(query_size)
{
*lwork = 0;
return 0;
}
if(*n==0 || *m==0)
return 0;
PlainMatrixType mat(*m,*n);
mat = matrix(a,*m,*n,*lda);
int option = *jobz=='A' ? ComputeFullU|ComputeFullV
: *jobz=='S' ? ComputeThinU|ComputeThinV
: *jobz=='O' ? ComputeThinU|ComputeThinV
: 0;
BDCSVD svd(mat,option);
make_vector(s,diag_size) = svd.singularValues().head(diag_size);
if(*jobz=='A')
{
matrix(u,*m,*m,*ldu) = svd.matrixU();
matrix(vt,*n,*n,*ldvt) = svd.matrixV().adjoint();
}
else if(*jobz=='S')
{
matrix(u,*m,diag_size,*ldu) = svd.matrixU();
matrix(vt,diag_size,*n,*ldvt) = svd.matrixV().adjoint();
}
else if(*jobz=='O' && *m>=*n)
{
matrix(a,*m,*n,*lda) = svd.matrixU();
matrix(vt,*n,*n,*ldvt) = svd.matrixV().adjoint();
}
else if(*jobz=='O')
{
matrix(u,*m,*m,*ldu) = svd.matrixU();
matrix(a,diag_size,*n,*lda) = svd.matrixV().adjoint();
}
return 0;
}
// computes the singular values/vectors a general M-by-N matrix A using two sided jacobi algorithm
EIGEN_LAPACK_FUNC(gesvd,(char *jobu, char *jobv, int *m, int* n, Scalar* a, int *lda, RealScalar *s, Scalar *u, int *ldu, Scalar *vt, int *ldvt, Scalar* /*work*/, int* lwork,
EIGEN_LAPACK_ARG_IF_COMPLEX(RealScalar */*rwork*/) int *info))
{
// TODO exploit the work buffer
bool query_size = *lwork==-1;
int diag_size = (std::min)(*m,*n);
*info = 0;
if( *jobu!='A' && *jobu!='S' && *jobu!='O' && *jobu!='N') *info = -1;
else if((*jobv!='A' && *jobv!='S' && *jobv!='O' && *jobv!='N')
|| (*jobu=='O' && *jobv=='O')) *info = -2;
else if(*m<0) *info = -3;
else if(*n<0) *info = -4;
else if(*lda svd(mat,option);
make_vector(s,diag_size) = svd.singularValues().head(diag_size);
{
if(*jobu=='A') matrix(u,*m,*m,*ldu) = svd.matrixU();
else if(*jobu=='S') matrix(u,*m,diag_size,*ldu) = svd.matrixU();
else if(*jobu=='O') matrix(a,*m,diag_size,*lda) = svd.matrixU();
}
{
if(*jobv=='A') matrix(vt,*n,*n,*ldvt) = svd.matrixV().adjoint();
else if(*jobv=='S') matrix(vt,diag_size,*n,*ldvt) = svd.matrixV().adjoint();
else if(*jobv=='O') matrix(a,diag_size,*n,*lda) = svd.matrixV().adjoint();
}
return 0;
}
piqp-octave/src/eigen/lapack/dlarf.f 0000644 0001751 0000177 00000014027 14107270226 017230 0 ustar runner docker *> \brief \b DLARF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARF applies a real elementary reflector H to a real m by n matrix
*> C, from either the left or the right. H is represented in the form
*>
*> H = I - tau * v * v**T
*>
*> where tau is a real scalar and v is a real vector.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': form H * C
*> = 'R': form C * H
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is DOUBLE PRECISION array, dimension
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
*> The vector v in the representation of H. V is not used if
*> TAU = 0.
*> \endverbatim
*>
*> \param[in] INCV
*> \verbatim
*> INCV is INTEGER
*> The increment between elements of v. INCV <> 0.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*> or C * H if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension
*> (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup doubleOTHERauxiliary
*
* =====================================================================
SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary 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 SIDE
INTEGER INCV, LDC, M, N
DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILADLR, ILADLC
EXTERNAL LSAME, ILADLR, ILADLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 0
LASTC = 0
IF( TAU.NE.ZERO ) THEN
! Set up variables for scanning V. LASTV begins pointing to the end
! of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
! Look for the last non-zero row in V.
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
! Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILADLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILADLR(M, LASTV, C, LDC)
END IF
END IF
! Note that lastc.eq.0 renders the BLAS operations null; no special
! case is needed at this level.
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
*
CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
$ ZERO, WORK, 1 )
*
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T
*
CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
$ V, INCV, ZERO, WORK, 1 )
*
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T
*
CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of DLARF
*
END
piqp-octave/src/eigen/lapack/dlapy2.f 0000644 0001751 0000177 00000004722 14107270226 017334 0 ustar runner docker *> \brief \b DLAPY2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAPY2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
*> overflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is DOUBLE PRECISION
*> X and Y specify the values x and y.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
* -- LAPACK auxiliary 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 ..
DOUBLE PRECISION X, Y
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION W, XABS, YABS, Z
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
XABS = ABS( X )
YABS = ABS( Y )
W = MAX( XABS, YABS )
Z = MIN( XABS, YABS )
IF( Z.EQ.ZERO ) THEN
DLAPY2 = W
ELSE
DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
END IF
RETURN
*
* End of DLAPY2
*
END
piqp-octave/src/eigen/lapack/cladiv.f 0000644 0001751 0000177 00000004444 14107270226 017404 0 ustar runner docker *> \brief \b CLADIV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* COMPLEX FUNCTION CLADIV( X, Y )
*
* .. Scalar Arguments ..
* COMPLEX X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLADIV := X / Y, where X and Y are complex. The computation of X / Y
*> will not overflow on an intermediary step unless the results
*> overflows.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is COMPLEX
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX
*> The complex scalars X and Y.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexOTHERauxiliary
*
* =====================================================================
COMPLEX FUNCTION CLADIV( X, Y )
*
* -- LAPACK auxiliary 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 ..
COMPLEX X, Y
* ..
*
* =====================================================================
*
* .. Local Scalars ..
REAL ZI, ZR
* ..
* .. External Subroutines ..
EXTERNAL SLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC AIMAG, CMPLX, REAL
* ..
* .. Executable Statements ..
*
CALL SLADIV( REAL( X ), AIMAG( X ), REAL( Y ), AIMAG( Y ), ZR,
$ ZI )
CLADIV = CMPLX( ZR, ZI )
*
RETURN
*
* End of CLADIV
*
END
piqp-octave/src/eigen/lapack/slarfg.f 0000644 0001751 0000177 00000011454 14107270226 017417 0 ustar runner docker *> \brief \b SLARFG
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLARFG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* REAL ALPHA, TAU
* ..
* .. Array Arguments ..
* REAL X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLARFG generates a real elementary reflector H of order n, such
*> that
*>
*> H * ( alpha ) = ( beta ), H**T * H = I.
*> ( x ) ( 0 )
*>
*> where alpha and beta are scalars, and x is an (n-1)-element real
*> vector. H is represented in the form
*>
*> H = I - tau * ( 1 ) * ( 1 v**T ) ,
*> ( v )
*>
*> where tau is a real scalar and v is a real (n-1)-element
*> vector.
*>
*> If the elements of x are all zero, then tau = 0 and H is taken to be
*> the unit matrix.
*>
*> Otherwise 1 <= tau <= 2.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the elementary reflector.
*> \endverbatim
*>
*> \param[in,out] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, the value alpha.
*> On exit, it is overwritten with the value beta.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is REAL array, dimension
*> (1+(N-2)*abs(INCX))
*> On entry, the vector x.
*> On exit, it is overwritten with the vector v.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between elements of X. INCX > 0.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is REAL
*> The value tau.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup realOTHERauxiliary
*
* =====================================================================
SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary 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 ..
INTEGER INCX, N
REAL ALPHA, TAU
* ..
* .. Array Arguments ..
REAL X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
REAL BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2, SNRM2
EXTERNAL SLAMCH, SLAPY2, SNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN
* ..
* .. External Subroutines ..
EXTERNAL SSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.1 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = SNRM2( N-1, X, INCX )
*
IF( XNORM.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
RSAFMN = ONE / SAFMIN
10 CONTINUE
KNT = KNT + 1
CALL SSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHA = ALPHA*RSAFMN
IF( ABS( BETA ).LT.SAFMIN )
$ GO TO 10
*
* New BETA is at most 1, at least SAFMIN
*
XNORM = SNRM2( N-1, X, INCX )
BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
END IF
TAU = ( BETA-ALPHA ) / BETA
CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
DO 20 J = 1, KNT
BETA = BETA*SAFMIN
20 CONTINUE
ALPHA = BETA
END IF
*
RETURN
*
* End of SLARFG
*
END
piqp-octave/src/eigen/lapack/zlarf.f 0000644 0001751 0000177 00000014206 14107270226 017255 0 ustar runner docker *> \brief \b ZLARF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* COMPLEX*16 TAU
* ..
* .. Array Arguments ..
* COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARF applies a complex elementary reflector H to a complex M-by-N
*> matrix C, from either the left or the right. H is represented in the
*> form
*>
*> H = I - tau * v * v**H
*>
*> where tau is a complex scalar and v is a complex vector.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*>
*> To apply H**H, supply conjg(tau) instead
*> tau.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': form H * C
*> = 'R': form C * H
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX*16 array, dimension
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
*> The vector v in the representation of H. V is not used if
*> TAU = 0.
*> \endverbatim
*>
*> \param[in] INCV
*> \verbatim
*> INCV is INTEGER
*> The increment between elements of v. INCV <> 0.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*> or C * H if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension
*> (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary 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 SIDE
INTEGER INCV, LDC, M, N
COMPLEX*16 TAU
* ..
* .. Array Arguments ..
COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZGERC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAZLR, ILAZLC
EXTERNAL LSAME, ILAZLR, ILAZLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 0
LASTC = 0
IF( TAU.NE.ZERO ) THEN
* Set up variables for scanning V. LASTV begins pointing to the end
* of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
* Look for the last non-zero row in V.
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
* Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILAZLC(LASTV, N, C, LDC)
ELSE
* Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILAZLR(M, LASTV, C, LDC)
END IF
END IF
* Note that lastc.eq.0 renders the BLAS operations null; no special
* case is needed at this level.
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
*
CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
$ C, LDC, V, INCV, ZERO, WORK, 1 )
*
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
*
CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
$ V, INCV, ZERO, WORK, 1 )
*
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
*
CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of ZLARF
*
END
piqp-octave/src/eigen/lapack/zlarfb.f 0000644 0001751 0000177 00000055712 14107270226 017426 0 ustar runner docker *> \brief \b ZLARFB
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
* T, LDT, C, LDC, WORK, LDWORK )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, SIDE, STOREV, TRANS
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
* $ WORK( LDWORK, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARFB applies a complex block reflector H or its transpose H**H to a
*> complex M-by-N matrix C, from either the left or the right.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply H or H**H from the Left
*> = 'R': apply H or H**H from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply H (No transpose)
*> = 'C': apply H**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Indicates how H is formed from a product of elementary
*> reflectors
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Indicates how the vectors which define the elementary
*> reflectors are stored:
*> = 'C': Columnwise
*> = 'R': Rowwise
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the matrix T (= the number of elementary
*> reflectors whose product defines the block reflector).
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX*16 array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
*> if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,K)
*> The triangular K-by-K matrix T in the representation of the
*> block reflector.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LDWORK,K)
*> \endverbatim
*>
*> \param[in] LDWORK
*> \verbatim
*> LDWORK is INTEGER
*> The leading dimension of the array WORK.
*> If SIDE = 'L', LDWORK >= max(1,N);
*> if SIDE = 'R', LDWORK >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored; the corresponding
*> array elements are modified but restored on exit. The rest of the
*> array is not used.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK auxiliary 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 DIRECT, SIDE, STOREV, TRANS
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J, LASTV, LASTC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAZLR, ILAZLC
EXTERNAL LSAME, ILAZLR, ILAZLC
* ..
* .. External Subroutines ..
EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'C'
ELSE
TRANST = 'N'
END IF
*
IF( LSAME( STOREV, 'C' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 ) (first K rows)
* ( V2 )
* where V1 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
LASTC = ILAZLC( 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 ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2**H *V2
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose',
$ LASTC, K, LASTV-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 ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTV-K, LASTC, K,
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK,
$ ONE, C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 30 J = 1, K
DO 20 I = 1, LASTC
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
20 CONTINUE
30 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
LASTC = ILAZLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL ZGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-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 ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - W * V2**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, LASTV-K, K,
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
$ ONE, C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, LASTC
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
ELSE
*
* Let V = ( V1 )
* ( V2 ) (last K rows)
* where V2 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
LASTC = ILAZLC( LASTV, 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 ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1**H*V1
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose',
$ LASTC, K, LASTV-K,
$ ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1 * W**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTV-K, LASTC, K,
$ -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
END IF
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W**H
*
DO 90 J = 1, K
DO 80 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
$ DCONJG( WORK( I, J ) )
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
LASTC = ILAZLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
$ WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL ZGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
END IF
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
$ - WORK( I, J )
110 CONTINUE
120 CONTINUE
END IF
END IF
*
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 V2 ) (V1: first K columns)
* where V1 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
LASTC = ILAZLC( 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 ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2**H*V2**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTC, K, LASTV-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 ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - V2**H * W**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTV-K, LASTC, K,
$ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
$ ONE, C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 150 J = 1, K
DO 140 I = 1, LASTC
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
140 CONTINUE
150 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
LASTC = ILAZLR( 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 ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, K, LASTV-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 ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL ZGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
$ ONE, C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, LASTC
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
*
END IF
*
ELSE
*
* Let V = ( V1 V2 ) (V2: last K columns)
* where V2 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
LASTC = ILAZLC( LASTV, 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 ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1**H * V1**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTC, K, LASTV-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1**H * W**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTV-K, LASTC, K,
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W**H
*
DO 210 J = 1, K
DO 200 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
$ DCONJG( WORK( I, J ) )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
LASTC = ILAZLR( M, LASTV, C, LDC )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
$ WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
$ WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL ZGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
$ - WORK( I, J )
230 CONTINUE
240 CONTINUE
*
END IF
*
END IF
END IF
*
RETURN
*
* End of ZLARFB
*
END
piqp-octave/src/eigen/lapack/zlarfg.f 0000644 0001751 0000177 00000012357 14107270226 017431 0 ustar runner docker *> \brief \b ZLARFG
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* COMPLEX*16 ALPHA, TAU
* ..
* .. Array Arguments ..
* COMPLEX*16 X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARFG generates a complex elementary reflector H of order n, such
*> that
*>
*> H**H * ( alpha ) = ( beta ), H**H * H = I.
*> ( x ) ( 0 )
*>
*> where alpha and beta are scalars, with beta real, and x is an
*> (n-1)-element complex vector. H is represented in the form
*>
*> H = I - tau * ( 1 ) * ( 1 v**H ) ,
*> ( v )
*>
*> where tau is a complex scalar and v is a complex (n-1)-element
*> vector. Note that H is not hermitian.
*>
*> If the elements of x are all zero and alpha is real, then tau = 0
*> and H is taken to be the unit matrix.
*>
*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the elementary reflector.
*> \endverbatim
*>
*> \param[in,out] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16
*> On entry, the value alpha.
*> On exit, it is overwritten with the value beta.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension
*> (1+(N-2)*abs(INCX))
*> On entry, the vector x.
*> On exit, it is overwritten with the vector v.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between elements of X. INCX > 0.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16
*> The value tau.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary 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 ..
INTEGER INCX, N
COMPLEX*16 ALPHA, TAU
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2
COMPLEX*16 ZLADIV
EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN
* ..
* .. External Subroutines ..
EXTERNAL ZDSCAL, ZSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = DZNRM2( N-1, X, INCX )
ALPHR = DBLE( ALPHA )
ALPHI = DIMAG( ALPHA )
*
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
RSAFMN = ONE / SAFMIN
*
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
10 CONTINUE
KNT = KNT + 1
CALL ZDSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHI = ALPHI*RSAFMN
ALPHR = ALPHR*RSAFMN
IF( ABS( BETA ).LT.SAFMIN )
$ GO TO 10
*
* New BETA is at most 1, at least SAFMIN
*
XNORM = DZNRM2( N-1, X, INCX )
ALPHA = DCMPLX( ALPHR, ALPHI )
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
END IF
TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
CALL ZSCAL( N-1, ALPHA, X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
DO 20 J = 1, KNT
BETA = BETA*SAFMIN
20 CONTINUE
ALPHA = BETA
END IF
*
RETURN
*
* End of ZLARFG
*
END
piqp-octave/src/eigen/lapack/zlacgv.f 0000644 0001751 0000177 00000005427 14107270226 017432 0 ustar runner docker *> \brief \b ZLACGV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLACGV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLACGV( N, X, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* ..
* .. Array Arguments ..
* COMPLEX*16 X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLACGV conjugates a complex vector of length N.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The length of the vector X. N >= 0.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension
*> (1+(N-1)*abs(INCX))
*> On entry, the vector of length N to be conjugated.
*> On exit, X is overwritten with conjg(X).
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The spacing between successive elements of X.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLACGV( N, X, INCX )
*
* -- LAPACK auxiliary 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 ..
INTEGER INCX, N
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IOFF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
IF( INCX.EQ.1 ) THEN
DO 10 I = 1, N
X( I ) = DCONJG( X( I ) )
10 CONTINUE
ELSE
IOFF = 1
IF( INCX.LT.0 )
$ IOFF = 1 - ( N-1 )*INCX
DO 20 I = 1, N
X( IOFF ) = DCONJG( X( IOFF ) )
IOFF = IOFF + INCX
20 CONTINUE
END IF
RETURN
*
* End of ZLACGV
*
END
piqp-octave/src/eigen/lapack/clarfb.f 0000644 0001751 0000177 00000055600 14107270226 017373 0 ustar runner docker *> \brief \b CLARFB
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLARFB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
* T, LDT, C, LDC, WORK, LDWORK )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, SIDE, STOREV, TRANS
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX C( LDC, * ), T( LDT, * ), V( LDV, * ),
* $ WORK( LDWORK, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLARFB applies a complex block reflector H or its transpose H**H to a
*> complex M-by-N matrix C, from either the left or the right.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply H or H**H from the Left
*> = 'R': apply H or H**H from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply H (No transpose)
*> = 'C': apply H**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Indicates how H is formed from a product of elementary
*> reflectors
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Indicates how the vectors which define the elementary
*> reflectors are stored:
*> = 'C': Columnwise
*> = 'R': Rowwise
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the matrix T (= the number of elementary
*> reflectors whose product defines the block reflector).
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
*> The matrix V. See Further Details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
*> if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] T
*> \verbatim
*> T is COMPLEX array, dimension (LDT,K)
*> The triangular K-by-K matrix T in the representation of the
*> block reflector.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (LDWORK,K)
*> \endverbatim
*>
*> \param[in] LDWORK
*> \verbatim
*> LDWORK is INTEGER
*> The leading dimension of the array WORK.
*> If SIDE = 'L', LDWORK >= max(1,N);
*> if SIDE = 'R', LDWORK >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexOTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored; the corresponding
*> array elements are modified but restored on exit. The rest of the
*> array is not used.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK auxiliary 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 DIRECT, SIDE, STOREV, TRANS
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J, LASTV, LASTC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILACLR, ILACLC
EXTERNAL LSAME, ILACLR, ILACLC
* ..
* .. External Subroutines ..
EXTERNAL CCOPY, CGEMM, CLACGV, CTRMM
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'C'
ELSE
TRANST = 'N'
END IF
*
IF( LSAME( STOREV, 'C' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 ) (first K rows)
* ( V2 )
* where V1 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* 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 )
10 CONTINUE
*
* W := W * V1
*
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2**H *V2
*
CALL CGEMM( 'Conjugate transpose', 'No transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - V * W**H
*
IF( M.GT.K ) THEN
*
* 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 )
END IF
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 30 J = 1, K
DO 20 I = 1, LASTC
C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
20 CONTINUE
30 CONTINUE
*
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 )
40 CONTINUE
*
* W := W * V1
*
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL CGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - W * V**H
*
IF( LASTV.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 )
END IF
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, LASTC
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
ELSE
*
* Let V = ( V1 )
* ( V2 ) (last K rows)
* where V2 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* 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 := C2**H
*
DO 70 J = 1, K
CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
CALL CLACGV( LASTC, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1**H*V1
*
CALL CGEMM( 'Conjugate transpose', 'No transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - V * W**H
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1 * W**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ LASTV-K, LASTC, 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( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W**H
*
DO 90 J = 1, K
DO 80 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
$ CONJG( WORK( I, J ) )
80 CONTINUE
90 CONTINUE
*
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 := C2
*
DO 100 J = 1, K
CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1,
$ WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL CGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - W * V**H
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, LASTV-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( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
$ - WORK( I, J )
110 CONTINUE
120 CONTINUE
END IF
END IF
*
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 V2 ) (V1: first K columns)
* where V1 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* 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 )
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
*
* 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 )
END IF
*
* W := W * T**H or W * T
*
CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
IF( LASTV.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 )
END IF
*
* W := W * V1
*
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 150 J = 1, K
DO 140 I = 1, LASTC
C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
140 CONTINUE
150 CONTINUE
*
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 )
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
*
* W := W + C2 * V2**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - W * V
*
IF( LASTV.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 )
END IF
*
* W := W * V1
*
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, LASTC
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
*
END IF
*
ELSE
*
* Let V = ( V1 V2 ) (V2: last K columns)
* where V2 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* 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 := C2**H
*
DO 190 J = 1, K
CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
CALL CLACGV( LASTC, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**H
*
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1**H * V1**H
*
CALL CGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTC, K, LASTV-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 )
*
* C := C - V**H * W**H
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1**H * W**H
*
CALL CGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTV-K, LASTC, 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, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W**H
*
DO 210 J = 1, K
DO 200 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
$ CONJG( WORK( I, J ) )
200 CONTINUE
210 CONTINUE
*
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 := C2
*
DO 220 J = 1, K
CALL CCOPY( LASTC, C( 1, LASTV-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, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1**H
*
CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, K, LASTV-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 )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL CGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-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, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
$ - WORK( I, J )
230 CONTINUE
240 CONTINUE
*
END IF
*
END IF
END IF
*
RETURN
*
* End of CLARFB
*
END
piqp-octave/src/eigen/COPYING.README 0000644 0001751 0000177 00000001413 14107270226 016520 0 ustar runner docker Eigen is primarily MPL2 licensed. See COPYING.MPL2 and these links:
http://www.mozilla.org/MPL/2.0/
http://www.mozilla.org/MPL/2.0/FAQ.html
Some files contain third-party code under BSD or LGPL licenses, whence the other
COPYING.* files here.
All the LGPL code is either LGPL 2.1-only, or LGPL 2.1-or-later.
For this reason, the COPYING.LGPL file contains the LGPL 2.1 text.
If you want to guarantee that the Eigen code that you are #including is licensed
under the MPL2 and possibly more permissive licenses (like BSD), #define this
preprocessor symbol:
EIGEN_MPL2_ONLY
For example, with most compilers, you could add this to your project CXXFLAGS:
-DEIGEN_MPL2_ONLY
This will cause a compilation error to be generated if you #include any code that is
LGPL licensed.
piqp-octave/src/eigen/scripts/ 0000755 0001751 0000177 00000000000 14107270226 016221 5 ustar runner docker piqp-octave/src/eigen/scripts/relicense.py 0000644 0001751 0000177 00000004500 14107270226 020543 0 ustar runner docker # This file is part of Eigen, a lightweight C++ template library
# for linear algebra.
#
# Copyright (C) 2012 Keir Mierle
#
# This Source Code Form is subject to the terms of the Mozilla
# Public License v. 2.0. If a copy of the MPL was not distributed
# with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
#
# Author: mierle@gmail.com (Keir Mierle)
#
# Make the long-awaited conversion to MPL.
lgpl3_header = '''
// Eigen is free software; you can redistribute it and/or
// modify it under the terms of the GNU Lesser General Public
// License as published by the Free Software Foundation; either
// version 3 of the License, or (at your option) any later version.
//
// Alternatively, you can redistribute it and/or
// modify it under the terms of the GNU General Public License as
// published by the Free Software Foundation; either version 2 of
// the License, or (at your option) any later version.
//
// Eigen is distributed in the hope that it will be useful, but WITHOUT ANY
// WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
// FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License or the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU Lesser General Public
// License and a copy of the GNU General Public License along with
// Eigen. If not, see .
'''
mpl2_header = """
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
"""
import os
import sys
exclusions = set(['relicense.py'])
def update(text):
if text.find(lgpl3_header) == -1:
return text, False
return text.replace(lgpl3_header, mpl2_header), True
rootdir = sys.argv[1]
for root, sub_folders, files in os.walk(rootdir):
for basename in files:
if basename in exclusions:
print 'SKIPPED', filename
continue
filename = os.path.join(root, basename)
fo = file(filename)
text = fo.read()
fo.close()
text, updated = update(text)
if updated:
fo = file(filename, "w")
fo.write(text)
fo.close()
print 'UPDATED', filename
else:
print ' ', filename
piqp-octave/src/eigen/scripts/check.in 0000755 0001751 0000177 00000001236 14107270226 017633 0 ustar runner docker #!/bin/bash
# check : shorthand for make and ctest -R
if [[ $# != 1 || $1 == *help ]]
then
echo "usage: $0 regexp"
echo " Builds and runs tests matching the regexp."
echo " The EIGEN_MAKE_ARGS environment variable allows to pass args to 'make'."
echo " For example, to launch 5 concurrent builds, use EIGEN_MAKE_ARGS='-j5'"
echo " The EIGEN_CTEST_ARGS environment variable allows to pass args to 'ctest'."
echo " For example, with CTest 2.8, you can use EIGEN_CTEST_ARGS='-j5'."
exit 0
fi
if [ -n "${EIGEN_CTEST_ARGS:+x}" ]
then
./buildtests.sh "$1" && ctest -R "$1" ${EIGEN_CTEST_ARGS}
else
./buildtests.sh "$1" && ctest -R "$1"
fi
exit $?
piqp-octave/src/eigen/scripts/debug.in 0000755 0001751 0000177 00000000054 14107270226 017641 0 ustar runner docker #!/bin/sh
cmake -DCMAKE_BUILD_TYPE=Debug .
piqp-octave/src/eigen/scripts/eigen_gen_credits.cpp 0000644 0001751 0000177 00000014360 14107270226 022366 0 ustar runner docker #include
#include
#include
#include
#include
#include