PDL-LinearAlgebra-0.12/0000755113142400244210000000000012535325333016763 5ustar chris.h.marshallDomain UsersPDL-LinearAlgebra-0.12/Artistic_20000644113142400244210000002072612247720255020722 0ustar chris.h.marshallDomain Users Artistic License 2.0 Copyright (c) 2000-2006, The Perl Foundation. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble This license establishes the terms under which a given free software Package may be copied, modified, distributed, and/or redistributed. The intent is that the Copyright Holder maintains some artistic control over the development of that Package while still keeping the Package available as open source and free software. You are always permitted to make arrangements wholly outside of this license directly with the Copyright Holder of a given Package. If the terms of this license do not permit the full use that you propose to make of the Package, you should contact the Copyright Holder and seek a different licensing arrangement. Definitions "Copyright Holder" means the individual(s) or organization(s) named in the copyright notice for the entire Package. "Contributor" means any party that has contributed code or other material to the Package, in accordance with the Copyright Holder's procedures. "You" and "your" means any person who would like to copy, distribute, or modify the Package. "Package" means the collection of files distributed by the Copyright Holder, and derivatives of that collection and/or of those files. A given Package may consist of either the Standard Version, or a Modified Version. "Distribute" means providing a copy of the Package or making it accessible to anyone else, or in the case of a company or organization, to others outside of your company or organization. "Distributor Fee" means any fee that you charge for Distributing this Package or providing support for this Package to another party. It does not mean licensing fees. "Standard Version" refers to the Package if it has not been modified, or has been modified only in ways explicitly requested by the Copyright Holder. "Modified Version" means the Package, if it has been changed, and such changes were not explicitly requested by the Copyright Holder. "Original License" means this Artistic License as Distributed with the Standard Version of the Package, in its current version or as it may be modified by The Perl Foundation in the future. "Source" form means the source code, documentation source, and configuration files for the Package. "Compiled" form means the compiled bytecode, object code, binary, or any other form resulting from mechanical transformation or translation of the Source form. Permission for Use and Modification Without Distribution (1) You are permitted to use the Standard Version and create and use Modified Versions for any purpose without restriction, provided that you do not Distribute the Modified Version. Permissions for Redistribution of the Standard Version (2) You may Distribute verbatim copies of the Source form of the Standard Version of this Package in any medium without restriction, either gratis or for a Distributor Fee, provided that you duplicate all of the original copyright notices and associated disclaimers. At your discretion, such verbatim copies may or may not include a Compiled form of the Package. (3) You may apply any bug fixes, portability changes, and other modifications made available from the Copyright Holder. The resulting Package will still be considered the Standard Version, and as such will be subject to the Original License. Distribution of Modified Versions of the Package as Source (4) You may Distribute your Modified Version as Source (either gratis or for a Distributor Fee, and with or without a Compiled form of the Modified Version) provided that you clearly document how it differs from the Standard Version, including, but not limited to, documenting any non-standard features, executables, or modules, and provided that you do at least ONE of the following: (a) make the Modified Version available to the Copyright Holder of the Standard Version, under the Original License, so that the Copyright Holder may include your modifications in the Standard Version. (b) ensure that installation of your Modified Version does not prevent the user installing or running the Standard Version. In addition, the Modified Version must bear a name that is different from the name of the Standard Version. (c) allow anyone who receives a copy of the Modified Version to make the Source form of the Modified Version available to others under (i) the Original License or (ii) a license that permits the licensee to freely copy, modify and redistribute the Modified Version using the same licensing terms that apply to the copy that the licensee received, and requires that the Source form of the Modified Version, and of any works derived from it, be made freely available in that license fees are prohibited but Distributor Fees are allowed. Distribution of Compiled Forms of the Standard Version or Modified Versions without the Source (5) You may Distribute Compiled forms of the Standard Version without the Source, provided that you include complete instructions on how to get the Source of the Standard Version. Such instructions must be valid at the time of your distribution. If these instructions, at any time while you are carrying out such distribution, become invalid, you must provide new instructions on demand or cease further distribution. If you provide valid instructions or cease distribution within thirty days after you become aware that the instructions are invalid, then you do not forfeit any of your rights under this license. (6) You may Distribute a Modified Version in Compiled form without the Source, provided that you comply with Section 4 with respect to the Source of the Modified Version. Aggregating or Linking the Package (7) You may aggregate the Package (either the Standard Version or Modified Version) with other packages and Distribute the resulting aggregation provided that you do not charge a licensing fee for the Package. Distributor Fees are permitted, and licensing fees for other components in the aggregation are permitted. The terms of this license apply to the use and Distribution of the Standard or Modified Versions as included in the aggregation. (8) You are permitted to link Modified and Standard Versions with other works, to embed the Package in a larger work of your own, or to build stand-alone binary or bytecode versions of applications that include the Package, and Distribute the result without restriction, provided the result does not expose a direct interface to the Package. Items That are Not Considered Part of a Modified Version (9) Works (including, but not limited to, modules and scripts) that merely extend or make use of the Package, do not, by themselves, cause the Package to be a Modified Version. In addition, such works are not considered parts of the Package itself, and are not subject to the terms of this license. General Provisions (10) Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. (11) If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. (12) This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. (13) This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. PDL-LinearAlgebra-0.12/Changes0000644113142400244210000000444412535325010020254 0ustar chris.h.marshallDomain UsersRevision history for Perl extension PDL::LinearAlgebra 0.12 Mon Jun 8 10:42:52 EDT 2015 * Fix last 'package PDL::Complex' * Add 'clean' option to remove *~ files 0.11 * Hide PDL and PDL::Complex package declarations from PAUSE/CPAN indexer 0.10 * Add -lquadmath to compiler flags for gfortran 0.09 * Use new GENERATE feature to make POD from PP files * Use correct meta-spec for META_MERGE * Require constant 1.03 - older version do not work with hashes. 0.08_03 * Test of KMX patch to Makefile.PL for better docs on metacpan.org and search.cpan.org * Improved library detection for SPP PDL edition 0.08_02 * Test of KMX patch to Makefile.PL 0.08_01 * Add AUTHOR and ABSTRACT info to Makefile.PL * Apply patch from CPAN RT bug #38167 * Fix encoding specs for POD 0.08 Tue Dec 3 06:07:55 EST 2013 * use VERSION_FROM in Makefile.PLs * update license to Artistic 2.0 * bump VERSION to 0.08 for official release 0.07_01 Sat Nov 30 18:17:48 EST 2013 * fixed bug in msyminv() * global conversion from DOS to UNIX line endings * explicitly specifying a Latin-1 encoding in the PODs * removed debianization. This package is already in debian * partial clean up of $VERSION specification 0.07 Wed Nov 27 17:09:40 EST 2013 * Official release with 1st PDL-2.007 support 0.06_02 Wed Nov 27 14:19:17 EST 2013 * fix CPAN dependency info so PDL is used for config 0.06_01 Sun Nov 17 11:21:52 2013 * update build to work with new PDL_Indx data type 0.06 Thu Oct 09 00:00:00 2007 * remove conflicting cplx routine (thanks to P. Dupre) * remove prototype of sec 0.05 Fri Aug 17 00:00:00 2007 * version information fixes 0.04 Thu Aug 16 00:00:00 2007 * mnorm fix (complex) * mfun fix (inplace operations are not supported on upstream PDL::Complex (PDL <= 2.4.3) * remove stringizing routine for PDL::Complex (in upstream now PDL >= 2.4.3) add format variables (forgotten in upstream PDL 2.4.3) * sumover for PDL::Complex fix (dims < 2) * documentation improvements and fixes 0.03 Mon Sep 12 18:05:15 2005 * documentation corrections 0.02 Wed Aug 24 13:39:15 2005 * mnorm threading * new routine mrcond * documentation corrections * add PDL.pm in prerequities (Makefile.PL) 0.01 Mon Aug 15 14:57:24 2005 * Initial release PDL-LinearAlgebra-0.12/Complex/0000755113142400244210000000000012535325330020367 5ustar chris.h.marshallDomain UsersPDL-LinearAlgebra-0.12/Complex/complex.pd0000644113142400244210000046657712535324043022414 0ustar chris.h.marshallDomain Users# TODO 'further details' ======= ========= do('../Config'); our $VERSION = '0.12'; pp_setversion(qq{'$VERSION'}); $VERSION = eval $VERSION; use PDL::Exporter; if ($config{CBLAS}){ pp_addhdr('#include '); } if ($^O =~ /MSWin/) { pp_addhdr(' #include '); } pp_addhdr(' #include #if defined(PDL_CORE_VERSION) && PDL_CORE_VERSION < 10 typedef PDL_Long PDL_Indx; #endif typedef PDL_Long logical; typedef PDL_Long integer; typedef PDL_Long ftnlen; #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif #ifndef min #define min(a,b) ((a) <= (b) ? (a) : (b)) #endif #ifndef max #define max(a,b) ((a) >= (b) ? (a) : (b)) #endif static integer c_zero = 0; static integer c_nine = 9; '); sub generate_code($){ if ($config{WITHOUT_THREAD}){ return ' #if 0 threadloop%{ %} #endif'.$_[0]; } else{ return $_[0]; } } sub pp_defc{ my $function = shift; pp_def(('c'.$function), Doc=>" =for ref Complex version of $function ", @_); } #pp_bless('PDL::Complex'); pp_addpm({At=>'Top'},<<'EOD'); use strict; use PDL::Complex; use PDL::LinearAlgebra::Real; { package # hide from CPAN PDL; my $warningFlag; BEGIN{ $warningFlag = $^W; $^W = 0; } use overload ( 'x' => sub {UNIVERSAL::isa($_[1],'PDL::Complex') ? PDL::cmmult(PDL::Complex::r2C($_[0]), $_[1]): PDL::mmult($_[0], $_[1]); }); BEGIN{ $^W = $warningFlag ; } } { package # hide from CPAN PDL::Complex; my $warningFlag; BEGIN{ $warningFlag = $^W; $^W = 0; } use overload ( 'x' => sub {UNIVERSAL::isa($_[1],'PDL::Complex') ? PDL::cmmult($_[0], $_[1]) : PDL::cmmult($_[0], PDL::Complex::r2C($_[1])); }, ); BEGIN{ $^W = $warningFlag ; } } =encoding Latin-1 =head1 NAME PDL::LinearAlgebra::Complex - PDL interface to the lapack linear algebra programming library (complex number) =head1 SYNOPSIS use PDL::Complex use PDL::LinearAlgebra::Complex; $a = r2C random (100,100); $s = r2C zeroes(100); $u = r2C zeroes(100,100); $v = r2C zeroes(100,100); $info = 0; $job = 0; cgesdd($a, $job, $info, $s , $u, $v); =head1 DESCRIPTION This module provides an interface to parts of the lapack library (complex numbers). These routines accept either float or double piddles. EOD pp_defc("gesvd", HandleBad => 0, RedoDimsCode => '$SIZE(r) = $PDL(A)->ndims > 2 ? min($PDL(A)->dims[1], $PDL(A)->dims[2]) : 1;', Pars => '[io,phys]A(2,m,n); int jobu(); int jobvt(); [o,phys]s(r); [o,phys]U(2,p,q); [o,phys]VT(2,s,t); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork; char trau, travt; types(F) %{ extern int cgesvd_(char *jobu, char *jobvt, integer *m, integer *n, float *a, integer *lda, float *s, float *u, int *ldu, float *vt, integer *ldvt, float *work, integer *lwork, float *rwork, integer *info); float *rwork; float tmp_work[2]; %} types(D) %{ extern int zgesvd_(char *jobz,char *jobvt, integer *m, integer *n, double *a, integer *lda, double *s, double *u, int *ldu, double *vt, integer *ldvt, double *work, integer *lwork, double *rwork, integer *info); double *rwork; double tmp_work[2]; %} lwork = ($PRIV(__m_size) < $PRIV(__n_size)) ? 5*$PRIV(__m_size) : 5*$PRIV(__n_size); types(F) %{ rwork = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ rwork = (double *)malloc(lwork * sizeof(double)); %} lwork = -1; switch ($jobu()) { case 1: trau = \'A\'; break; case 2: trau = \'S\'; break; case 3: trau = \'O\'; break; default: trau = \'N\'; } switch ($jobvt()) { case 1: travt = \'A\'; break; case 2: travt = \'S\'; break; case 3: travt = \'O\'; break; default: travt = \'N\'; } $TFD(cgesvd_,zgesvd_)( &trau, &travt, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(s), $P(U), &(integer){$PRIV(__p_size)}, $P(VT), &(integer){$PRIV(__s_size)}, &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(cgesvd_,zgesvd_)( &trau, &travt, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(s), $P(U), &(integer){$PRIV(__p_size)}, $P(VT), &(integer){$PRIV(__s_size)}, work, &lwork, rwork, $P(info)); free(work); } free(rwork); ', Doc=>' =for ref Complex version of gesvd. The SVD is written A = U * SIGMA * ConjugateTranspose(V) '); pp_defc("gesdd", HandleBad => 0, RedoDimsCode => '$SIZE(r) = $PDL(A)->ndims > 2 ? min($PDL(A)->dims[1], $PDL(A)->dims[2]) : 1;', Pars => '[io,phys]A(2,m,n); int job(); [o,phys]s(r); [o,phys]U(2,p,q); [o,phys]VT(2,s,t); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork; integer *iwork; char tra; types(F) %{ extern int cgesdd_(char *jobz, integer *m, integer *n, float * a, integer *lda, float *s, float *u, int *ldu, float *vt, integer *ldvt, float *work, integer *lwork, float *rwork, integer *iwork, integer *info); float *rwork; float tmp_work[2]; %} types(D) %{ extern int zgesdd_(char *jobz, integer *m, integer *n, double * a, integer *lda, double *s, double *u, int *ldu, double *vt, integer *ldvt, double *work, integer *lwork, double *rwork, integer *iwork, integer *info); double *rwork; double tmp_work[2]; %} lwork = ($PRIV(__m_size) < $PRIV(__n_size)) ? $PRIV(__m_size) : $PRIV(__n_size); iwork = (integer *)malloc(lwork * 8 * sizeof(integer)); types(F) %{ switch ($job()) { case 1: tra = \'A\'; rwork = (float *)malloc( (5 * lwork *lwork + 5 * lwork) * sizeof(float)); break; case 2: tra = \'S\'; rwork = (float *)malloc( (5 * lwork *lwork + 5 * lwork) * sizeof(float)); break; case 3: tra = \'O\'; rwork = (float *)malloc( (5 * lwork *lwork + 5 * lwork) * sizeof(float)); break; default: tra = \'N\'; rwork = (float *)malloc( 7 * lwork * sizeof(float)); break; } %} types(D) %{ switch ($job()) { case 1: tra = \'A\'; rwork = (double *)malloc( (5 * lwork *lwork + 5 * lwork) * sizeof(double)); break; case 2: tra = \'S\'; rwork = (double *)malloc( (5 * lwork *lwork + 5 * lwork) * sizeof(double)); break; case 3: tra = \'O\'; rwork = (double *)malloc( (5 * lwork *lwork + 5 * lwork) * sizeof(double)); break; default: tra = \'N\'; rwork = (double *)malloc( 7 * lwork * sizeof(double)); break; } %} lwork = -1; $TFD(cgesdd_,zgesdd_)( &tra, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(s), $P(U), &(integer){$PRIV(__p_size)}, $P(VT), &(integer){$PRIV(__s_size)}, &tmp_work[0], &lwork, rwork, iwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgesdd_,zgesdd_)( &tra, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(s), $P(U), &(integer){$PRIV(__p_size)}, $P(VT), &(integer){$PRIV(__s_size)}, work, &lwork, rwork, iwork, $P(info)); free(work); } free(iwork); free(rwork); ', Doc=>' =for ref Complex version of gesdd. The SVD is written A = U * SIGMA * ConjugateTranspose(V) '); pp_defc("ggsvd", HandleBad => 0, Pars => '[io,phys]A(2,m,n); int jobu(); int jobv(); int jobq(); [io,phys]B(2,p,n); int [o,phys]k(); int [o,phys]l();[o,phys]alpha(n);[o,phys]beta(n); [o,phys]U(2,q,r); [o,phys]V(2,s,t); [o,phys]Q(2,u,v); int [o,phys]iwork(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pjobu = \'N\'; char pjobv = \'N\'; char pjobq = \'N\'; types(F) %{ extern int cggsvd_(char *jobu, char *jobv, char *jobq, integer *m, integer *n, integer *p, integer *k, integer *l, float *a, integer *lda, float *b, integer *ldb, float *alpha, float *beta, float *u, integer *ldu, float *v, integer *ldv, float *q, integer *ldq, float *work, float *rwork, integer *iwork, integer *info); float *work, *rwork; %} types(D) %{ extern int zggsvd_(char *jobu, char *jobv, char *jobq, integer *m, integer *n, integer *p, integer *k, integer *l, double *a, integer *lda, double *b, integer *ldb, double *alpha, double *beta, double *u, integer *ldu, double *v, integer *ldv, double *q, integer *ldq, double *work, double *rwork, integer *iwork, integer *info); double *work, *rwork; %} integer lwork = ($SIZE (m) < $SIZE (n)) ? $SIZE (n): $SIZE (m); if ($SIZE (p) > lwork) lwork = $SIZE (p); types(F) %{ work = (float *)malloc(2*(3*lwork + $SIZE (n))* sizeof(float)); rwork = (float *)malloc(2 * $SIZE (n) * sizeof(float)); %} types(D) %{ work = (double *)malloc(2*(3*lwork + $SIZE (n)) * sizeof(double)); rwork = (double *)malloc(2 * $SIZE (n) * sizeof(double)); %} if ($jobu()) pjobu = \'U\'; if ($jobv()) pjobv = \'V\'; if ($jobq()) pjobq = \'Q\'; $TFD(cggsvd_,zggsvd_)( &pjobu, &pjobv, &pjobq, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__p_size)}, $P(k), $P(l), $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(alpha), $P(beta), $P(U), &(integer){$PRIV(__q_size)}, $P(V), &(integer){$PRIV(__s_size)}, $P(Q), &(integer){$PRIV(__u_size)}, work, rwork, $P(iwork), $P(info)); free(rwork); free(work); '); pp_defc("geev", HandleBad => 0, Pars => '[phys]A(2,n,n); int jobvl(); int jobvr(); [o,phys]w(2,n); [o,phys]vl(2,m,m); [o,phys]vr(2,p,p); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jvl = \'N\'; char jvr = \'N\'; types(F) %{ extern int cgeev_(char *jobvl, char *jobvr, integer *n, float *a, integer *lda, float *w, float *vl, integer *ldvl, float *vr, integer *ldvr, float *work, integer *lwork, float *rwork, integer *info); float tmp_work[2], *rwork; %} types(D) %{ extern int zgeev_(char *jobvl, char *jobvr, integer *n, double * a, integer *lda, double *w, double *vl, integer *ldvl, double *vr, integer *ldvr, double *work, integer *lwork, double *rwork, integer *info); double tmp_work[2], *rwork; %} integer lwork = -1; if ($jobvl()) jvl = \'V\'; if ($jobvr()) jvr = \'V\'; types(F) %{ rwork = (float *)malloc( 2 * $PRIV(__n_size) * sizeof(float)); %} types(D) %{ rwork = (double *)malloc(2 * $PRIV(__n_size) * sizeof(double)); %} $TFD(cgeev_,zgeev_)( &jvl, &jvr, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), $P(vl), &(integer){$PRIV(__m_size)}, $P(vr), &(integer){$PRIV(__p_size)}, &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(cgeev_,zgeev_)( &jvl, &jvr, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), $P(vl), &(integer){$PRIV(__m_size)}, $P(vr), &(integer){$PRIV(__p_size)}, work, &lwork, rwork, $P(info)); free(work); } free(rwork); '); pp_defc("geevx", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int jobvl(); int jobvr(); int balance(); int sense(); [o,phys]w(2,n); [o,phys]vl(2,m,m); [o,phys]vr(2,p,p); int [o,phys]ilo(); int [o,phys]ihi(); [o,phys]scale(n); [o,phys]abnrm(); [o,phys]rconde(q); [o,phys]rcondv(r); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jvl = \'N\'; char jvr = \'N\'; char balanc, sens; integer lwork = -1; types(F) %{ extern int cgeevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, float *a, integer *lda, float *w, float *vl, integer *ldvl, float *vr, integer *ldvr, integer *ilo, integer *ihi, float *scale, float *abnrm, float *rconde, float *rcondv, float *work, integer *lwork, float *rwork, integer *info); float tmp_work[2], *rwork; %} types(D) %{ extern int zgeevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, double *a, integer *lda, double *w, double *vl, integer *ldvl, double *vr, integer *ldvr, integer *ilo, integer *ihi, double *scale, double *abnrm, double *rconde, double *rcondv, double *work, integer *lwork, double *rwork, integer *info); double tmp_work[2], *rwork; %} if ($jobvl()) jvl = \'V\'; if ($jobvr()) jvr = \'V\'; switch ($balance()) { case 1: balanc = \'P\'; break; case 2: balanc = \'S\'; break; case 3: balanc = \'B\'; break; default: balanc = \'N\'; } switch ($sense()) { case 1: sens = \'E\'; break; case 2: sens = \'V\'; break; case 3: sens = \'B\'; break; default: sens = \'N\'; } types(F) %{ rwork = (float *)malloc( 2 * $PRIV(__n_size) * sizeof(float)); %} types(D) %{ rwork = (double *)malloc(2 * $PRIV(__n_size) * sizeof(double)); %} $TFD(cgeevx_,zgeevx_)( &balanc, &jvl, &jvr, &sens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), $P(vl), &(integer){$PRIV(__m_size)}, $P(vr), &(integer){$PRIV(__p_size)}, $P(ilo), $P(ihi), $P(scale), $P(abnrm), $P(rconde), $P(rcondv), &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgeevx_,zgeevx_)( &balanc, &jvl, &jvr, &sens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), $P(vl), &(integer){$PRIV(__m_size)}, $P(vr), &(integer){$PRIV(__p_size)}, $P(ilo), $P(ihi), $P(scale), $P(abnrm), $P(rconde), $P(rcondv), work, &lwork, rwork, $P(info)); free(work); } free(rwork); '); pp_defc("ggev", HandleBad => 0, Pars => '[phys]A(2,n,n); int jobvl();int jobvr();[phys]B(2,n,n);[o,phys]alpha(2,n);[o,phys]beta(2,n);[o,phys]VL(2,m,m);[o,phys]VR(2,p,p);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; char pjobvl = \'N\', pjobvr = \'N\'; types(F) %{ extern int cggev_(char *jobvl, char *jobvr, integer *n, float * a, integer *lda, float *b, integer *ldb, float *alpha, float *beta, float *vl, integer *ldvl, float *vr, integer *ldvr, float *work, integer *lwork, float *rwork, integer *info); float tmp_work[2], *rwork; %} types(D) %{ extern int zggev_(char *jobvl, char *jobvr, integer *n, double * a, integer *lda, double *b, integer *ldb, double *alpha, double *beta, double *vl, integer *ldvl, double *vr, integer *ldvr, double *work, integer *lwork, double *rwork, integer *info); double tmp_work[2], *rwork; %} if ($jobvl()) pjobvl = \'V\'; if ($jobvr()) pjobvr = \'V\'; types(F) %{ rwork = (float *)malloc(8 * $SIZE(n) * sizeof(float)); %} types(D) %{ rwork = (double *)malloc(8 * $SIZE(n) * sizeof(double)); %} $TFD(cggev_,zggev_)( &pjobvl, &pjobvr, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(alpha), $P(beta), $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cggev_,zggev_)( &pjobvl, &pjobvr, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(alpha), $P(beta), $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, work, &lwork, rwork, $P(info)); free(work); } free(rwork); '); pp_defc("ggevx", HandleBad => 0, Pars => '[io,phys]A(2,n,n);int balanc();int jobvl();int jobvr();int sense();[io,phys]B(2,n,n);[o,phys]alpha(2,n);[o,phys]beta(2,n);[o,phys]VL(2,m,m);[o,phys]VR(2,p,p);int [o,phys]ilo();int [o,phys]ihi();[o,phys]lscale(n);[o,phys]rscale(n);[o,phys]abnrm();[o,phys]bbnrm();[o,phys]rconde(r);[o,phys]rcondv(s);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1, *iwork, *bwork; char pjobvl = \'N\', pjobvr = \'N\'; char pbalanc, psens; types(F) %{ int cggevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, float *a, integer *lda, float *b, integer *ldb, float *alpha, float * beta, float *vl, integer *ldvl, float *vr, integer *ldvr, integer *ilo, integer *ihi, float *lscale, float *rscale, float *abnrm, float *bbnrm, float *rconde, float * rcondv, float *work, integer *lwork, float *rwork, integer *iwork, logical * bwork, integer *info); float tmp_work[2], *rwork; rwork = (float *)malloc(6 * $SIZE(n) * sizeof(float)); %} types(D) %{ extern int zggevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, double *a, integer *lda, double *b, integer *ldb, double *alpha, double * beta, double *vl, integer *ldvl, double *vr, integer *ldvr, integer *ilo, integer *ihi, double *lscale, double *rscale, double *abnrm, double *bbnrm, double *rconde, double * rcondv, double *work, integer *lwork, double *rwork, integer *iwork, logical * bwork, integer *info); double tmp_work[2], *rwork; rwork = (double *)malloc(6 * $SIZE(n) * sizeof(double)); %} if ($jobvl()) pjobvl = \'V\'; if ($jobvr()) pjobvr = \'V\'; switch ($balanc()) { case 1: pbalanc = \'P\'; break; case 2: pbalanc = \'S\'; break; case 3: pbalanc = \'B\'; break; default: pbalanc = \'N\'; } switch ($sense()) { case 1: psens = \'E\'; bwork = (integer *)malloc($SIZE(n) * sizeof(integer)); break; case 2: psens = \'V\'; iwork = (integer *)malloc(($SIZE(n) + 2) * sizeof(integer)); bwork = (integer *)malloc($SIZE(n) * sizeof(integer)); break; case 3: psens = \'B\'; iwork = (integer *)malloc(($SIZE(n) + 2) * sizeof(integer)); bwork = (integer *)malloc($SIZE(n) * sizeof(integer)); break; default: psens = \'N\'; iwork = (integer *)malloc(($SIZE(n) + 2) * sizeof(integer)); } $TFD(cggevx_,zggevx_)( &pbalanc, &pjobvl, &pjobvr, &psens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(alpha), $P(beta), $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, $P(ilo), $P(ihi), $P(lscale), $P(rscale), $P(abnrm), $P(bbnrm), $P(rconde), $P(rcondv), &tmp_work[0], &lwork, rwork, iwork, bwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cggevx_,zggevx_)( &pbalanc, &pjobvl, &pjobvr, &psens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(alpha), $P(beta), $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, $P(ilo), $P(ihi), $P(lscale), $P(rscale), $P(abnrm), $P(bbnrm), $P(rconde), $P(rcondv), work, &lwork, rwork, iwork, bwork, $P(info)); free(work); } free(rwork); if ($sense()) free(bwork); if ($sense() != 1) free(iwork); '); pp_addhdr(' static SV* fselect_func; PDL_Long fselect_wrapper(float *p) { dSP ; int count; long ret; SV *pdl1; HV *bless_stash; pdl *pdl; PDL_Indx odims[1]; PDL_Indx dims[] = {2,1}; pdl = PDL->pdlnew(); PDL->setdims (pdl, dims, 2); pdl->datatype = PDL_F; pdl->data = p; pdl->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; bless_stash = gv_stashpv("PDL::Complex", 0); ENTER ; SAVETMPS ; PUSHMARK(sp) ; pdl1 = sv_newmortal(); PDL->SetSV_PDL(pdl1, pdl); pdl1 = sv_bless(pdl1, bless_stash); /* bless in PDL::Complex */ XPUSHs(pdl1); PUTBACK ; count = perl_call_sv(fselect_func, G_SCALAR); SPAGAIN; if (count !=1) croak("Error calling perl function\n"); // For pdl_free odims[0] = 0; PDL->setdims (pdl, odims, 0); pdl->state &= ~ (PDL_ALLOCATED |PDL_DONTTOUCHDATA); pdl->data=NULL; ret = (long ) POPl ; PUTBACK ; FREETMPS ; LEAVE ; return ret; } static SV* dselect_func; PDL_Long dselect_wrapper(double *p) { dSP ; int count; long ret; SV *pdl1; HV *bless_stash; pdl *pdl; PDL_Indx odims[1]; PDL_Indx dims[] = {2,1}; pdl = PDL->pdlnew(); PDL->setdims (pdl, dims, 2); pdl->datatype = PDL_D; pdl->data = p; pdl->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; bless_stash = gv_stashpv("PDL::Complex", 0); ENTER ; SAVETMPS ; PUSHMARK(sp) ; pdl1 = sv_newmortal(); PDL->SetSV_PDL(pdl1, pdl); pdl1 = sv_bless(pdl1, bless_stash); /* bless in PDL::Complex */ XPUSHs(pdl1); PUTBACK ; count = perl_call_sv(dselect_func, G_SCALAR); SPAGAIN; if (count !=1) croak("Error calling perl function\n"); // For pdl_free odims[0] = 0; PDL->setdims (pdl, odims, 0); pdl->state &= ~ (PDL_ALLOCATED |PDL_DONTTOUCHDATA); pdl->data=NULL; ret = (long ) POPl ; PUTBACK ; FREETMPS ; LEAVE ; return ret; } '); pp_defc("gees", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int jobvs(); int sort(); [o,phys]w(2,n); [o,phys]vs(2,p,p); int [o,phys]sdim(); int [o,phys]info()', OtherPars => "SV* select_func" , GenericTypes => [F,D], Code => generate_code ' char jvs = \'N\'; char psort = \'N\'; integer *bwork; integer lwork = -1; types(F) %{ extern int cgees_(char *jobvs, char *sort, L_fp select, integer *n, float *a, integer *lda, integer *sdim, float *w, float *vs, integer *ldvs, float *work, integer *lwork, float *rwork, integer *bwork, integer *info); float tmp_work[2]; float *rwork, *work; rwork = (float *) malloc ($PRIV(__n_size) * sizeof (float)); fselect_func = $PRIV(select_func); %} types(D) %{ extern int zgees_(char *jobvs, char *sort, L_fp select, integer *n, double *a, integer *lda, integer *sdim, double *w, double *vs, integer *ldvs, double *work, integer *lwork, double *rwork, integer *bwork, integer *info); double *rwork, *work; double tmp_work[2]; dselect_func = $PRIV(select_func); rwork = (double *) malloc ($PRIV(__n_size) * sizeof (double)); %} if ($jobvs()) jvs = \'V\'; if ($sort()){ psort = \'S\'; bwork = (integer * ) malloc ($PRIV(__n_size) * sizeof (integer)); } types(F) %{ cgees_( &jvs, &psort, fselect_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(w), $P(vs), &(integer){$PRIV(__p_size)}, &tmp_work[0], &lwork, rwork, bwork, $P(info)); %} types(D) %{ zgees_( &jvs, &psort, dselect_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(w), $P(vs), &(integer){$PRIV(__p_size)}, &tmp_work[0], &lwork, rwork, bwork, $P(info)); %} lwork = (integer )tmp_work[0]; types(F) %{ work = (float *) malloc(2 * lwork * sizeof(float)); cgees_( &jvs, &psort, fselect_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(w), $P(vs), &(integer){$PRIV(__p_size)}, work, &lwork, rwork, bwork, $P(info)); free(work); %} types(D) %{ work = (double *) malloc(2*lwork * sizeof(double)); zgees_( &jvs, &psort, dselect_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(w), $P(vs), &(integer){$PRIV(__p_size)}, work, &lwork, rwork, bwork, $P(info)); free(work); %} if ($sort()) free(bwork); free(rwork); ', Doc=>' =for ref Complex version of gees select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form. If sort = 0, select_func is not referenced. An complex eigenvalue w is selected if select_func(PDL::Complex(w)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func(PDL::Complex(w)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info is set to N+2. '); pp_defc("geesx", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int jobvs(); int sort(); int sense(); [o,phys]w(2,n);[o,phys]vs(2,p,p); int [o,phys]sdim(); [o,phys]rconde();[o,phys]rcondv(); int [o,phys]info()', OtherPars => "SV* select_func" , GenericTypes => [F,D], Code => generate_code ' char jvs = \'N\'; char psort = \'N\'; integer *bwork; integer lwork = 0; char sens; types(F) %{ extern int cgeesx_(char *jobvs, char *sort, L_fp select, char * sense, integer *n, float *a, integer *lda, integer *sdim, float *w, float *vs, integer *ldvs, float *rconde, float *rcondv, float *work, integer *lwork, float *rwork, integer *bwork, integer *info); float *work, *rwork; rwork = (float *) malloc ($PRIV(__n_size) * sizeof (float)); fselect_func = $PRIV(select_func); %} types(D) %{ extern int zgeesx_(char *jobvs, char *sort, L_fp select, char * sense, integer *n, double *a, integer *lda, integer *sdim, double *w, double *vs, integer *ldvs, double *rconde, double *rcondv, double *work, integer *lwork, double *rwork, integer *bwork, integer *info); double *work, *rwork; dselect_func = $PRIV(select_func); rwork = (double *) malloc ($PRIV(__n_size) * sizeof (double)); %} if ($jobvs()) jvs = \'V\'; if ($sort()){ psort = \'S\'; bwork = (integer * ) malloc ($PRIV(__n_size) * sizeof (integer)); } switch ($sense()) { case 1: sens = \'E\'; lwork = (integer ) ($PRIV(__n_size) * ($PRIV(__n_size)/2)); break; case 2: sens = \'V\'; lwork = (integer ) ($PRIV(__n_size) * ($PRIV(__n_size)/2)); break; case 3: sens = \'B\'; lwork = (integer ) ($PRIV(__n_size) * ($PRIV(__n_size)/2)); break; default: sens = \'N\'; lwork = (integer ) ($PRIV(__n_size) * 2); } types(D) %{ work = (double * )malloc(2*lwork * sizeof (double)); %} types(F) %{ work = (float * )malloc(2*lwork * sizeof (float)); %} types(F) %{ cgeesx_( &jvs, &psort, fselect_wrapper, &sens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(w), $P(vs), &(integer){$PRIV(__p_size)}, $P(rconde), $P(rcondv), work, &lwork, rwork, bwork, $P(info)); %} types(D) %{ zgeesx_( &jvs, &psort, dselect_wrapper, &sens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(w), $P(vs), &(integer){$PRIV(__p_size)}, $P(rconde), $P(rcondv), work, &lwork, rwork, bwork, $P(info)); %} free(work); if ($sort()) free(bwork); free(rwork); ', Doc => ' =for ref Complex version of geesx select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form. If sort = 0, select_func is not referenced. An complex eigenvalue w is selected if select_func(PDL::Complex(w)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func(PDL::Complex(w)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info is set to N+2. '); pp_addhdr(' static SV* fgselect_func; PDL_Long fgselect_wrapper(float *p, float *q) { dSP ; int count; long ret; SV *svpdl1, *svpdl2; HV *bless_stash; pdl *pdl1, *pdl2; PDL_Indx odims[1]; PDL_Indx dims[] = {2,1}; pdl1 = PDL->pdlnew(); PDL->setdims (pdl1, dims, 2); pdl1->datatype = PDL_F; pdl1->data = p; pdl1->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; pdl2 = PDL->pdlnew(); PDL->setdims (pdl2, dims, 2); pdl2->datatype = PDL_F; pdl2->data = q; pdl2->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; bless_stash = gv_stashpv("PDL::Complex", 0); ENTER ; SAVETMPS ; PUSHMARK(sp) ; svpdl1 = sv_newmortal(); PDL->SetSV_PDL(svpdl1, pdl1); svpdl1 = sv_bless(svpdl1, bless_stash); /* bless in PDL::Complex */ svpdl2 = sv_newmortal(); PDL->SetSV_PDL(svpdl2, pdl2); svpdl2 = sv_bless(svpdl2, bless_stash); /* bless in PDL::Complex */ XPUSHs(svpdl1); XPUSHs(svpdl2); PUTBACK ; count = perl_call_sv(fgselect_func, G_SCALAR); SPAGAIN; if (count !=1) croak("Error calling perl function\n"); // For pdl_free odims[0] = 0; PDL->setdims (pdl1, odims, 0); pdl1->state &= ~ (PDL_ALLOCATED |PDL_DONTTOUCHDATA); pdl1->data=NULL; PDL->setdims (pdl2, odims, 0); pdl1->state &= ~ (PDL_ALLOCATED |PDL_DONTTOUCHDATA); pdl1->data=NULL; ret = (long ) POPl ; PUTBACK ; FREETMPS ; LEAVE ; return ret; } static SV* dgselect_func; PDL_Long dgselect_wrapper(double *p, double *q) { dSP ; int count; long ret; SV *svpdl1, *svpdl2; HV *bless_stash; pdl *pdl1, *pdl2; PDL_Indx odims[1]; PDL_Indx dims[] = {2,1}; pdl1 = PDL->pdlnew(); PDL->setdims (pdl1, dims, 2); pdl1->datatype = PDL_D; pdl1->data = p; pdl1->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; pdl2 = PDL->pdlnew(); PDL->setdims (pdl2, dims, 2); pdl2->datatype = PDL_D; pdl2->data = q; pdl2->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; bless_stash = gv_stashpv("PDL::Complex", 0); ENTER ; SAVETMPS ; PUSHMARK(sp) ; svpdl1 = sv_newmortal(); PDL->SetSV_PDL(svpdl1, pdl1); svpdl1 = sv_bless(svpdl1, bless_stash); /* bless in PDL::Complex */ svpdl2 = sv_newmortal(); PDL->SetSV_PDL(svpdl2, pdl2); svpdl2 = sv_bless(svpdl2, bless_stash); /* bless in PDL::Complex */ XPUSHs(svpdl1); XPUSHs(svpdl2); PUTBACK ; count = perl_call_sv(dgselect_func, G_SCALAR); SPAGAIN; if (count !=1) croak("Error calling perl function\n"); // For pdl_free odims[0] = 0; PDL->setdims (pdl1, odims, 0); pdl1->state &= ~ (PDL_ALLOCATED |PDL_DONTTOUCHDATA); pdl1->data=NULL; PDL->setdims (pdl2, odims, 0); pdl2->state &= ~ (PDL_ALLOCATED |PDL_DONTTOUCHDATA); pdl2->data=NULL; ret = (long ) POPl ; PUTBACK ; FREETMPS ; LEAVE ; return ret; } '); pp_defc("gges", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int jobvsl();int jobvsr();int sort();[io,phys]B(2,n,n);[o,phys]alpha(2,n);[o,phys]beta(2,n);[o,phys]VSL(2,m,m);[o,phys]VSR(2,p,p);int [o,phys]sdim();int [o,phys]info()', OtherPars => "SV* select_func" , GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; char pjobvsl = \'N\', pjobvsr = \'N\', psort = \'N\'; integer *bwork; types(F) %{ extern int cgges_(char *jobvsl, char *jobvsr, char *sort, L_fp delctg, integer *n, float *a, integer *lda, float *b, integer *ldb, integer *sdim, float *alpha, float *beta, float *vsl, integer *ldvsl, float *vsr, integer *ldvsr, float *work, integer *lwork, float *rwork, logical *bwork, integer *info); float tmp_work[2], *rwork; fgselect_func = $PRIV(select_func); rwork = (float *)malloc(8 * $SIZE(n) * sizeof(float)); %} types(D) %{ extern int zgges_(char *jobvsl, char *jobvsr, char *sort, L_fp delctg, integer *n, double *a, integer *lda, double *b, integer *ldb, integer *sdim, double *alpha, double *beta, double *vsl, integer *ldvsl, double *vsr, integer *ldvsr, double *work, integer *lwork, double *rwork, logical *bwork, integer *info); double tmp_work[2], *rwork; dgselect_func = $PRIV(select_func); rwork = (double *)malloc(8 * $SIZE(n) * sizeof(double)); %} if ($jobvsl()) pjobvsl = \'V\'; if ($jobvsr()) pjobvsr = \'V\'; if ($sort()){ psort = \'S\'; bwork = (integer *)malloc($PRIV(__n_size) * sizeof(integer)); } types(F) %{ cgges_( &pjobvsl, &pjobvsr, &psort, fgselect_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alpha), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, &tmp_work[0], &lwork, rwork, bwork, $P(info)); %} types(D) %{ zgges_( &pjobvsl, &pjobvsr, &psort, dgselect_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alpha), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, &tmp_work[0], &lwork, rwork, bwork, $P(info)); %} lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} types(F) %{ cgges_( &pjobvsl, &pjobvsr, &psort, fgselect_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alpha), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, work, &lwork, rwork, bwork, $P(info)); %} types(D) %{ zgges_( &pjobvsl, &pjobvsr, &psort, dgselect_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alpha), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, work, &lwork, rwork, bwork, $P(info)); %} free(work); } if ($sort()) free (bwork); free(rwork); ', Doc=>' =for ref Complex version of ggees select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form. If sort = 0, select_func is not referenced. An eigenvalue w = w/beta is selected if select_func(PDL::Complex(w), PDL::Complex(beta)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func(PDL::Complex(w),PDL::Complex(beta)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info is set to N+2. '); pp_defc("ggesx", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int jobvsl();int jobvsr();int sort();int sense();[io,phys]B(2,n,n);[o,phys]alpha(2,n);[o,phys]beta(2,n);[o,phys]VSL(2,m,m);[o,phys]VSR(2,p,p);int [o,phys]sdim();[o,phys]rconde(q);[o,phys]rcondv(r);int [o,phys]info()', OtherPars => "SV* select_func" , GenericTypes => [F,D], Code => generate_code ' integer lwork, maxwrk; integer liwork = 1; integer minwrk = 1; static integer c__0 = 0; static integer c__1 = 1; static integer c_n1 = -1; char pjobvsl = \'N\'; char pjobvsr = \'N\'; char psort = \'N\'; char psens = \'N\'; integer *bwork; integer *iwork; extern integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen opts_len); types(F) %{ extern int cggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp delctg, char *sense, integer *n, float *a, integer *lda, float *b, integer *ldb, integer *sdim, float *alpha, float *beta, float *vsl, integer *ldvsl, float *vsr, integer *ldvsr, float *rconde, float *rcondv, float *work, integer *lwork, float *rwork, integer *iwork, integer *liwork, logical *bwork, integer *info); float *rwork = (float *)malloc(8 * $SIZE(n) * sizeof(float)); fgselect_func = $PRIV(select_func); %} types(D) %{ extern int zggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp delctg, char *sense, integer *n, double *a, integer *lda, double *b, integer *ldb, integer *sdim, double *alpha, double *beta, double *vsl, integer *ldvsl, double *vsr, integer *ldvsr, double *rconde, double *rcondv, double *work, integer *lwork, double *rwork, integer *iwork, integer *liwork, logical *bwork, integer *info); double *rwork = (double *)malloc(8 * $SIZE(n) * sizeof(double)); dgselect_func = $PRIV(select_func); %} if ($jobvsr()) pjobvsr = \'V\'; if ($sort()){ psort = \'S\'; bwork = (integer *)malloc($PRIV(__n_size) * sizeof(integer)); } switch ($sense()) { case 1: psens = \'E\'; break; case 2: psens = \'V\'; break; case 3: psens = \'B\'; break; default: psens = \'N\'; } // if (!$sense()) // liwork = 1; // else // { liwork = $SIZE(n) + 2; iwork = (integer *)malloc(liwork * sizeof(integer)); // } // Code modified from Lapack // TODO other shur form above // The actual updated release (clapack 09/20/2000) do not allow // the workspace query. See release notes of Lapack // for this feature. minwrk = $SIZE(n) << 1; maxwrk = $SIZE(n) + $SIZE(n) * ilaenv_(&c__1, "ZGEQRF", " ", &(integer){$PRIV(__n_size)}, &c__1, &(integer){$PRIV(__n_size)}, &c__0, (ftnlen)6, (ftnlen)1); if ($jobvsl()) { integer i__1 = maxwrk; integer i__2 = $SIZE(n) + $SIZE(n) * ilaenv_(&c__1, "ZUNGQR" , " ", &(integer){$PRIV(__n_size)}, &c__1, &(integer){$PRIV(__n_size)}, &c_n1, (ftnlen)6, (ftnlen)1); maxwrk = max(i__1,i__2); pjobvsl = \'V\'; } lwork = max(maxwrk,minwrk); { types(F) %{ float *work = (float *)malloc( 2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} types(F) %{ cggesx_( &pjobvsl, &pjobvsr, &psort, fgselect_wrapper, &psens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alpha), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, $P(rconde), $P(rcondv), work, &lwork, rwork, iwork, &liwork, bwork, $P(info)); %} types(D) %{ zggesx_( &pjobvsl, &pjobvsr, &psort, dgselect_wrapper, &psens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alpha), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, $P(rconde), $P(rcondv), work, &lwork, rwork, iwork, &liwork, bwork, $P(info)); %} free(work); } if ($sort()) free (bwork); // if ($sense()) free(iwork); free(rwork); ', Doc=>' =for ref Complex version of ggeesx select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form. If sort = 0, select_func is not referenced. An eigenvalue w = w/beta is selected if select_func(PDL::Complex(w), PDL::Complex(beta)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func(PDL::Complex(w),PDL::Complex(beta)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info is set to N+3. '); pp_defc("heev", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int jobz(); int uplo(); [o,phys]w(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int cheev_(char *jobz, char *uplo, integer *n, float *a, integer *lda, float *w, float *work, integer *lwork, float *rwork, integer *info); float *rwork; float tmp_work[2]; rwork = (float *) malloc ((3*$PRIV(__n_size)-2) * sizeof(float)); %} types(D) %{ extern int zheev_(char *jobz, char *uplo, integer *n, double *a, integer *lda, double *w, double *work, integer *lwork, double *rwork, integer *info); double *rwork; double tmp_work[2]; rwork = (double *) malloc ((3*$PRIV(__n_size)-2) * sizeof(double)); %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; $TFD(cheev_,zheev_)( &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(cheev_,zheev_)( &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), work, &lwork, rwork, $P(info)); free(work); } free(rwork); ', Doc=>' =for ref Complex version of syev for Hermitian matrix '); pp_defc("heevd", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int jobz(); int uplo(); [o,phys]w(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; integer lwork = -1; integer lrwork, liwork; integer tmpi_work; integer *iwork; types(F) %{ extern int cheevd_(char *jobz, char *uplo, integer *n, float *a, integer *lda, float *w, float *work, integer *lwork, float *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info); float tmp_work[2]; float tmpr_work; %} types(D) %{ extern int zheevd_(char *jobz, char *uplo, integer *n, double *a, integer *lda, double *w, double *work, integer *lwork, double *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info); double tmp_work[2]; double tmpr_work; %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; $TFD(cheevd_,zheevd_)( &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), &tmp_work[0], &lwork, &tmpr_work, &lwork, &tmpi_work, &lwork, $P(info)); lwork = (integer )tmp_work[0]; lrwork = (integer )tmpr_work; liwork = (integer )tmpi_work; iwork = (integer *)malloc(liwork * sizeof(integer)); { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); float *rwork = (float *)malloc(lrwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); double *rwork = (double *)malloc(lrwork * sizeof(double)); %} $TFD(cheevd_,zheevd_)( &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), work, &lwork, rwork, &lrwork, iwork, &liwork, $P(info)); free(rwork); free(work); } free(iwork); ', Doc=>' =for ref Complex version of syevd for Hermitian matrix '); pp_defc("heevx", HandleBad => 0, Pars => '[phys]A(2,n,n); int jobz(); int range(); int uplo(); [phys]vl(); [phys]vu(); int [phys]il(); int [phys]iu(); [phys]abstol(); int [o,phys]m(); [o,phys]w(n); [o,phys]z(2,p,q);int [o,phys]ifail(r); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; char prange = \'A\'; integer lwork = -1; integer *iwork; types(F) %{ extern int cheevx_(char *jobz, char *range, char *uplo, integer *n, float *a, integer *lda, float *vl, float *vu, integer * il, integer *iu, float *abstol, integer *m, float *w, float *z__, integer *ldz, float *work, integer *lwork, float *rwork, integer *iwork, integer *ifail, integer *info); float *rwork; float tmp_work[2]; rwork = (float *)malloc(7 * $SIZE(n) * sizeof(float)); %} types(D) %{ extern int zheevx_(char *jobz, char *range, char *uplo, integer *n, double *a, integer *lda, double *vl, double *vu, integer * il, integer *iu, double *abstol, integer *m, double *w, double *z__, integer *ldz, double *work, integer *lwork, double *rwork, integer *iwork, integer *ifail, integer *info); double *rwork; double tmp_work[2]; rwork = (double *)malloc(7 * $SIZE(n) * sizeof(double)); %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; switch ($range()) { case 1: prange = \'V\'; break; case 2: prange = \'I\'; break; default: prange = \'A\'; } iwork = (integer *)malloc(5 * $SIZE (n) * sizeof(integer)); $TFD(cheevx_,zheevx_)( &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(z), &(integer){$PRIV(__p_size)}, &tmp_work[0], &lwork, rwork, iwork, $P(ifail), $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2* lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cheevx_,zheevx_)( &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(z), &(integer){$PRIV(__p_size)}, work, &lwork, rwork, iwork, $P(ifail), $P(info)); free(work); } free(iwork); free(rwork); ', Doc=>' =for ref Complex version of syevx for Hermitian matrix '); pp_defc("heevr", HandleBad => 0, Pars => '[phys]A(2,n,n); int jobz(); int range(); int uplo(); [phys]vl(); [phys]vu(); int [phys]il(); int [phys]iu(); [phys]abstol(); int [o,phys]m(); [o,phys]w(n); [o,phys]z(2,p,q);int [o,phys]isuppz(r); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; char prange = \'A\'; integer lwork = -1; integer liwork,lrwork; integer tmpi_work; types(F) %{ extern int cheevr_(char *jobz, char *range, char *uplo, integer *n, float *a, integer *lda, float *vl, float *vu, integer * il, integer *iu, float *abstol, integer *m, float *w, float *z__, integer *ldz, integer *isuppz, float *work, integer *lwork, float *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info); float tmp_work[2]; float tmpr_work; %} types(D) %{ extern int zheevr_(char *jobz, char *range, char *uplo, integer *n, double *a, integer *lda, double *vl, double *vu, integer * il, integer *iu, double *abstol, integer *m, double *w, double *z__, integer *ldz, integer *isuppz, double *work, integer *lwork, double *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info); double tmp_work[2]; double tmpr_work; %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; switch ($range()) { case 1: prange = \'V\'; break; case 2: prange = \'I\'; break; default: prange = \'A\'; } $TFD(cheevr_,zheevr_)( &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(z), &(integer){$PRIV(__p_size)}, $P(isuppz), &tmp_work[0], &lwork, &tmpr_work, &lwork, &tmpi_work, &lwork, $P(info)); lwork = (integer )tmp_work[0]; lrwork = (integer )tmpr_work; liwork = (integer )tmpi_work; { types(F) %{ float *work = (float *)malloc(2* lwork * sizeof(float)); float *rwork = (float *)malloc(lrwork * sizeof(float)); integer *iwork = (integer *)malloc(liwork * sizeof(integer)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); double *rwork = (double *)malloc(lrwork * sizeof(double)); integer *iwork = (integer *)malloc(liwork * sizeof(integer)); %} $TFD(cheevr_,zheevr_)( &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(z), &(integer){$PRIV(__p_size)}, $P(isuppz), work, &lwork, rwork, &lrwork, iwork, &liwork, $P(info)); free(work); free(iwork); free(rwork); } ', Doc=>' =for ref Complex version of syevr for Hermitian matrix '); pp_defc("hegv", HandleBad => 0, Pars => '[io,phys]A(2,n,n);int [phys]itype();int jobz(); int uplo();[io,phys]B(2,n,n);[o,phys]w(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int chegv_(integer *itype, char *jobz, char *uplo, integer * n, float *a, integer *lda, float *b, integer *ldb, float *w, float *work, integer *lwork, float *rwork, integer *info); float tmp_work[2], *rwork; rwork = (float *) malloc( (3 * $SIZE(n) - 2 ) * sizeof(float)); %} types(D) %{ extern int zhegv_(integer *itype, char *jobz, char *uplo, integer * n, double *a, integer *lda, double *b, integer *ldb, double *w, double *work, integer *lwork, double *rwork, integer *info); double tmp_work[2], *rwork; rwork = (double *) malloc( (3 * $SIZE(n) - 2 ) * sizeof(double)); %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; $TFD(chegv_,zhegv_)( $P(itype), &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(w), &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(chegv_,zhegv_)( $P(itype), &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(w), work, &lwork, rwork, $P(info)); free(work); } free(rwork); ', Doc=>' =for ref Complex version of sygv for Hermitian matrix '); pp_defc("hegvd", HandleBad => 0, Pars => '[io,phys]A(2,n,n);int [phys]itype();int jobz(); int uplo();[io,phys]B(2,n,n);[o,phys]w(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; integer lwork = -1; integer liwork = -1; integer lrwork = -1; integer *iwork; integer tmp_iwork; types(F) %{ extern int chegvd_(integer *itype, char *jobz, char *uplo, integer * n, float *a, integer *lda, float *b, integer *ldb, float *w, float *work, integer *lwork, float *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info); float tmp_work[2], tmp_rwork; %} types(D) %{ extern int zhegvd_(integer *itype, char *jobz, char *uplo, integer * n, double *a, integer *lda, double *b, integer *ldb, double *w, double *work, integer *lwork, double *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info); double tmp_work[2], tmp_rwork; %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; $TFD(chegvd_,zhegvd_)( $P(itype), &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(w), &tmp_work[0], &lwork, &tmp_rwork, &lrwork, &tmp_iwork, &liwork, $P(info)); lwork = (integer )tmp_work[0]; lrwork = (integer )tmp_rwork; liwork = (integer )tmp_iwork; iwork = (integer *)malloc(liwork * sizeof(integer)); { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); float *rwork = (float *)malloc(lrwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); double *rwork = (double *)malloc(lrwork * sizeof(double)); %} $TFD(chegvd_,zhegvd_)( $P(itype), &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(w), work, &lwork, rwork, &lrwork, iwork, &liwork, $P(info)); free(work); free(rwork); } free(iwork); ', Doc=>' =for ref Complex version of sygvd for Hermitian matrix '); pp_defc("hegvx", HandleBad => 0, Pars => '[io,phys]A(2,n,n);int [phys]itype();int jobz();int range(); int uplo();[io,phys]B(2,n,n);[phys]vl();[phys]vu();int [phys]il();int [phys]iu();[phys]abstol();int [o,phys]m();[o,phys]w(n); [o,phys]Z(2,p,q);int [o,phys]ifail(r);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; char prange; integer lwork = -1; integer *iwork; types(F) %{ extern int chegvx_(integer *itype, char *jobz, char *range, char * uplo, integer *n, float *a, integer *lda, float *b, integer *ldb, float *vl, float *vu, integer *il, integer *iu, float *abstol, integer *m, float *w, float *z__, integer *ldz, float *work, integer *lwork, float *rwork, integer *iwork, integer *ifail, integer *info); float tmp_work[2], *rwork; rwork = (float *)malloc(7 * $SIZE(n) * sizeof(float)); %} types(D) %{ extern int zhegvx_(integer *itype, char *jobz, char *range, char * uplo, integer *n, double *a, integer *lda, double *b, integer *ldb, double *vl, double *vu, integer *il, integer *iu, double *abstol, integer *m, double *w, double *z__, integer *ldz, double *work, integer *lwork, double *rwork, integer *iwork, integer *ifail, integer *info); double tmp_work[2], *rwork; rwork = (double *)malloc(7 * $SIZE(n) * sizeof(double)); %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; switch ($range()) { case 1: prange = \'V\'; break; case 2: prange = \'I\'; break; default: prange = \'A\'; } iwork = (integer *)malloc((5 * $SIZE(n)) * sizeof(integer)); $TFD(chegvx_,zhegvx_)( $P(itype), &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(Z), &(integer){$PRIV(__p_size)}, &tmp_work[0], &lwork, rwork, iwork, $P(ifail), $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc( 2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc( 2 * lwork * sizeof(double)); %} $TFD(chegvx_,zhegvx_)( $P(itype), &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(Z), &(integer){$PRIV(__p_size)}, work, &lwork, rwork, iwork, $P(ifail), $P(info)); free(work); } free(iwork); free(rwork); ', Doc=>' =for ref Complex version of sygvx for Hermitian matrix '); pp_defc("gesv", HandleBad => 0, Pars => '[io,phys]A(2,n,n); [io,phys]B(2,n,m); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' types(F) %{ extern int cgesv_(integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer *ldb, integer *info); %} types(D) %{ extern int zgesv_(integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer *ldb, integer *info); %} $TFD(cgesv_,zgesv_)( &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(info)); '); pp_defc("gesvx", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int trans(); int fact(); [io,phys]B(2,n,m); [io,phys]af(2,n,n); int [io,phys]ipiv(n); int [io]equed(); [io,phys]r(n); [io,phys]c(n); [o,phys]X(2,n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); [o,phys]rpvgrw(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans, pfact, pequed; types(F) %{ extern int cgesvx_(char *fact, char *trans, integer *n, integer * nrhs, float *a, integer *lda, float *af, integer *ldaf, integer *ipiv, char *equed, float *r__, float *c__, float *b, integer *ldb, float *x, integer *ldx, float * rcond, float *ferr, float *berr, float *work, float * rwork, integer *info); float *work = (float *) malloc(4 * $PRIV(__n_size) * sizeof(float)); float *rwork = (float *) malloc(4 * $PRIV(__n_size) * sizeof(float)); %} types(D) %{ extern int zgesvx_(char *fact, char *trans, integer *n, integer * nrhs, double *a, integer *lda, double *af, integer *ldaf, integer *ipiv, char *equed, double *r__, double *c__, double *b, integer *ldb, double *x, integer *ldx, double * rcond, double *ferr, double *berr, double *work, double * rwork, integer *info); double *work = (double *) malloc(4 * $PRIV(__n_size) * sizeof(double)); double *rwork = (double *) malloc(4 * $PRIV(__n_size) * sizeof(double)); %} switch ($trans()) { case 1: ptrans = \'T\'; break; case 2: ptrans = \'C\'; break; default: ptrans = \'N\'; } switch ($fact()) { case 1: pfact = \'N\'; break; case 2: pfact = \'E\'; break; default: pfact = \'F\'; } switch ($equed()) { case 1: pequed = \'R\'; break; case 2: pequed = \'C\'; break; case 3: pequed = \'B\'; break; default: pequed = \'N\'; } $TFD(cgesvx_,zgesvx_)( &pfact, &ptrans, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(af), &(integer){$PRIV(__n_size)}, $P(ipiv), &pequed, $P(r), $P(c), $P(B), &(integer){$PRIV(__n_size)}, $P(X), &(integer){$PRIV(__n_size)}, $P(rcond), $P(ferr), $P(berr), work, rwork, $P(info)); free(work); free(rwork); switch (pequed) { case \'R\': $equed() = 1; break; case \'C\': $equed() = 2; break; case \'B\': $equed() = 3; break; default: $equed()= 0; } $rpvgrw() = rwork[0]; ', Doc => ' =for ref Complex version of gesvx. trans: Specifies the form of the system of equations: = 0: A * X = B (No transpose) = 1: A\' * X = B (Transpose) = 2: A**H * X = B (Conjugate transpose) '); pp_defc("sysv", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); [io,phys]B(2,n,m); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int csysv_(char *uplo, integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer *ldb, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zsysv_(char *uplo, integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer *ldb, double *work, integer *lwork, integer *info); double tmp_work[2]; %} if ($uplo()) puplo = \'L\'; $TFD(csysv_,zsysv_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(csysv_,zsysv_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, work, &lwork, $P(info)); } '); pp_defc("sysvx", HandleBad => 0, Pars => '[phys]A(2,n,n); int uplo(); int fact(); [phys]B(2,n,m); [io,phys]af(2,n,n); int [io,phys]ipiv(n); [o,phys]X(2,n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pfact = \'N\'; char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int csysvx_(char *fact, char *uplo, integer *n, integer * nrhs, float *a, integer *lda, float *af, integer *ldaf, integer *ipiv, float *b, integer *ldb, float *x, integer * ldx, float *rcond, float *ferr, float *berr, float *work, integer *lwork, float *rwork, integer *info); float *rwork = (float * )malloc ($PRIV(__n_size)* sizeof (float)); float tmp_work[2]; %} types(D) %{ extern int zsysvx_(char *fact, char *uplo, integer *n, integer * nrhs, double *a, integer *lda, double *af, integer *ldaf, integer *ipiv, double *b, integer *ldb, double *x, integer * ldx, double *rcond, double *ferr, double *berr, double *work, integer *lwork, double *rwork, integer *info); double *rwork = (double * )malloc ($PRIV(__n_size)* sizeof (double)); double tmp_work[2]; %} if($fact()) pfact = \'F\'; if ($uplo()) puplo = \'L\'; $TFD(csysvx_,zsysvx_)( &pfact, &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(af), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(X), &(integer){$PRIV(__n_size)}, $P(rcond), $P(ferr), $P(berr), &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(csysvx_,zsysvx_)( &pfact, &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(af), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(X), &(integer){$PRIV(__n_size)}, $P(rcond), $P(ferr), $P(berr), work, &lwork, rwork, $P(info)); free(work); } free(rwork); '); pp_defc("hesv", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); [io,phys]B(2,n,m); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int chesv_(char *uplo, integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer *ldb, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zhesv_(char *uplo, integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer *ldb, double *work, integer *lwork, integer *info); double tmp_work[2]; %} if ($uplo()) puplo = \'L\'; $TFD(chesv_,zhesv_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(chesv_,zhesv_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, work, &lwork, $P(info)); } ', Doc=>' =for ref Complex version of sysv for Hermitian matrix '); pp_defc("hesvx", HandleBad => 0, Pars => '[phys]A(2,n,n); int uplo(); int fact(); [phys]B(2,n,m); [io,phys]af(2,n,n); int [io,phys]ipiv(n); [o,phys]X(2,n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pfact = \'N\'; char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int chesvx_(char *fact, char *uplo, integer *n, integer * nrhs, float *a, integer *lda, float *af, integer *ldaf, integer *ipiv, float *b, integer *ldb, float *x, integer * ldx, float *rcond, float *ferr, float *berr, float *work, integer *lwork, float *rwork, integer *info); float *rwork = (float * )malloc ($PRIV(__n_size)* sizeof (float)); float tmp_work[2]; %} types(D) %{ extern int zhesvx_(char *fact, char *uplo, integer *n, integer * nrhs, double *a, integer *lda, double *af, integer *ldaf, integer *ipiv, double *b, integer *ldb, double *x, integer * ldx, double *rcond, double *ferr, double *berr, double *work, integer *lwork, double *rwork, integer *info); double *rwork = (double * )malloc ($PRIV(__n_size)* sizeof (double)); double tmp_work[2]; %} if($fact()) pfact = \'F\'; if ($uplo()) puplo = \'L\'; $TFD(chesvx_,zhesvx_)( &pfact, &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(af), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(X), &(integer){$PRIV(__n_size)}, $P(rcond), $P(ferr), $P(berr), &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(chesvx_,zhesvx_)( &pfact, &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(af), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(X), &(integer){$PRIV(__n_size)}, $P(rcond), $P(ferr), $P(berr), work, &lwork, rwork, $P(info)); free(work); } free(rwork); ', Doc=>' =for ref Complex version of sysvx for Hermitian matrix '); pp_defc("posv", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); [io,phys]B(2,n,m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int cposv_(char *uplo, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, integer *info); %} types(D) %{ extern int zposv_(char *uplo, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(cposv_,zposv_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc=>' =for ref Complex version of posv for Hermitian positive definite matrix '); pp_defc("posvx", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int fact(); [io,phys]B(2,n,m); [io,phys]af(2,n,n); int [io]equed(); [io,phys]s(n); [o,phys]X(2,n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pfact; char pequed = \'N\'; char puplo = \'U\'; types(F) %{ extern int cposvx_(char *fact, char *uplo, integer *n, integer * nrhs, float *a, integer *lda, float *af, integer *ldaf, char *equed, float *s, float *b, integer *ldb, float * x, integer *ldx, float *rcond, float *ferr, float * berr, float *work, float *rwork, integer *info); float *work, *rwork; %} types(D) %{ extern int zposvx_(char *fact, char *uplo, integer *n, integer * nrhs, double *a, integer *lda, double *af, integer *ldaf, char *equed, double *s, double *b, integer *ldb, double * x, integer *ldx, double *rcond, double *ferr, double * berr, double *work, double *rwork, integer *info); double *work, *rwork; %} switch ($fact()) { case 1: pfact = \'N\'; break; case 2: pfact = \'E\'; break; default: pfact = \'F\'; } if ($equed()) pequed = \'Y\'; if ($uplo()) puplo = \'L\'; types(F) %{ work = (float *) malloc(4 * $PRIV(__n_size) * sizeof(float)); rwork = (float *) malloc(2 * $PRIV(__n_size) * sizeof(float)); %} types(D) %{ work = (double *) malloc(4 * $PRIV(__n_size) * sizeof(double)); rwork = (double *) malloc(2 * $PRIV(__n_size) * sizeof(double)); %} $TFD(cposvx_,zposvx_)( &pfact, &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(af), &(integer){$PRIV(__n_size)}, &pequed, $P(s), $P(B), &(integer){$PRIV(__n_size)}, $P(X), &(integer){$PRIV(__n_size)}, $P(rcond), $P(ferr), $P(berr), work, rwork, $P(info)); free(work); free(rwork); switch (pequed) { case \'Y\': $equed() = 1; break; default: $equed()= 0; } ', Doc => ' =for ref Complex version of posvx for Hermitian positive definite matrix '); pp_defc("gels", HandleBad => 0, Pars => '[io,phys]A(2,m,n); int trans(); [io,phys]B(2,p,q);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\'; integer lwork = -1; types(F) %{ extern int cgels_(char *trans, integer *m, integer *n, integer * nrhs, float *a, integer *lda, float *b, integer *ldb, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zgels_(char *trans, integer *m, integer *n, integer * nrhs, double *a, integer *lda, double *b, integer *ldb, double *work, integer *lwork, integer *info); double tmp_work[2]; %} if($trans()) ptrans = \'C\'; $TFD(cgels_,zgels_)( &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(cgels_,zgels_)( &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Solves overdetermined or underdetermined complex linear systems involving an M-by-N matrix A, or its conjugate-transpose. Complex version of gels. trans: = 0: the linear system involves A; = 1: the linear system involves A**H. '); pp_defc("gelsy", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [io,phys]B(2,p,q); [phys]rcond(); int [io,phys]jpvt(n); int [o,phys]rank();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cgelsy_(integer *m, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, integer * jpvt, float *rcond, integer *rank, float *work, integer * lwork, float *rwork, integer *info); float tmp_work[2]; float *rwork; %} types(D) %{ extern int zgelsy_(integer *m, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, integer * jpvt, double *rcond, integer *rank, double *work, integer * lwork, double *rwork, integer *info); double tmp_work[2]; double *rwork; %} types(F) %{ rwork = (float *)malloc( 2 * $PRIV(__m_size) * sizeof(float)); %} types(D) %{ rwork = (double *)malloc(2 * $PRIV(__m_size) * sizeof(double)); %} $TFD(cgelsy_,zgelsy_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(jpvt), $P(rcond), $P(rank), &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgelsy_,zgelsy_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(jpvt), $P(rcond), $P(rank), work, &lwork, rwork, $P(info)); free(work); } free(rwork); '); pp_defc("gelss", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [io,phys]B(2,p,q); [phys]rcond(); [o,phys]s(r); int [o,phys]rank();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; integer lrwork; types(F) %{ extern int cgelss_(integer *m, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, float *s, float *rcond, integer *rank, float *work, integer * lwork, float *rwork, integer *info); float tmp_work[2]; float *rwork; %} types(D) %{ extern int zgelss_(integer *m, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, double *s,double *rcond, integer *rank, double *work, integer * lwork, double *rwork, integer *info); double tmp_work[2]; double *rwork; %} lrwork = min($PRIV(__m_size), $PRIV(__n_size)); types(F) %{ rwork = (float *)malloc(5 * lrwork * sizeof(float)); %} types(D) %{ rwork = (double *)malloc(5 * lrwork * sizeof(double)); %} $TFD(cgelss_,zgelss_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(s), $P(rcond), $P(rank), &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgelss_,zgelss_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(s), $P(rcond), $P(rank), work, &lwork, rwork, $P(info)); free(work); } free(rwork); '); pp_defc("gelsd", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [io,phys]B(2,p,q); [phys]rcond(); [o,phys]s(r); int [o,phys]rank();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; integer smlsiz, size_i, nlvl, *iwork; integer minmn = min( $SIZE(m), $SIZE(n) ); extern integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen opts_len); types(F) %{ extern int cgelsd_(integer *m, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, float *s, float *rcond, integer *rank, float *work, integer * lwork, float *rwork, integer *iwork, integer *info); float *rwork; float tmp_work[2]; %} types(D) %{ extern int zgelsd_(integer *m, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, double *s,double *rcond, integer *rank, double *work, integer * lwork, double *rwork, integer *iwork,integer *info); double *rwork; double tmp_work[2]; %} minmn = max(1,minmn); types(F) %{ smlsiz = ilaenv_(&c_nine, "CGELSD", " ", &c_zero, &c_zero, &c_zero, &c_zero, (ftnlen)6, (ftnlen)1); size_i = (integer) (log((float) minmn / (float) (smlsiz + 1)) /log(2.)) + 1; if ($PRIV(__m_size) >= $PRIV(__n_size)){ rwork = (float *) malloc ((10*$PRIV(__n_size) + 2 * $PRIV(__n_size) * smlsiz + 8 * $PRIV(__n_size) * size_i + 3 * smlsiz * $PRIV(__q_size) + pow((smlsiz+1),2)) * sizeof(float)); } else{ rwork = (float *) malloc ((10*$PRIV(__m_size) + 2 * $PRIV(__m_size) * smlsiz + 8 * $PRIV(__m_size) * size_i + 3 * smlsiz * $PRIV(__q_size) + pow((smlsiz+1),2)) * sizeof(float)); } %} types(D) %{ smlsiz = ilaenv_(&c_nine, "ZGELSD", " ", &c_zero, &c_zero, &c_zero, &c_zero, (ftnlen)6, (ftnlen)1); size_i = (integer) (log((double) minmn / (double) (smlsiz + 1)) /log(2.)) + 1; if ($PRIV(__m_size) >= $PRIV(__n_size)){ rwork = (double *) malloc ((10*$PRIV(__n_size) + 2 * $PRIV(__n_size) * smlsiz + 8 * $PRIV(__n_size) * size_i + 3 * smlsiz * $PRIV(__q_size) + pow((smlsiz+1),2)) * sizeof(double)); } else{ rwork = (double *) malloc ((10*$PRIV(__m_size) + 2 * $PRIV(__m_size) * smlsiz + 8 * $PRIV(__m_size) * size_i + 3 * smlsiz * $PRIV(__q_size) + pow((smlsiz+1),2)) * sizeof(double)); } %} nlvl = max(size_i, 0); iwork = (integer *)malloc((3 * minmn * nlvl + 11 * minmn) * sizeof(integer)); $TFD(cgelsd_,zgelsd_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(s), $P(rcond), $P(rank), &tmp_work[0], &lwork, rwork, iwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgelsd_,zgelsd_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(s), $P(rcond), $P(rank), work, &lwork, rwork, iwork, $P(info)); free(work); } free (iwork); free (rwork); '); pp_defc("gglse", HandleBad => 0, Pars => '[phys]A(2,m,n); [phys]B(2,p,n);[io,phys]c(2,m);[phys]d(2,p);[o,phys]x(2,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cgglse_(integer *m, integer *n, integer *p, float * a, integer *lda, float *b, integer *ldb, float *c__, float *d__, float *x, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zgglse_(integer *m, integer *n, integer *p, double * a, integer *lda, double *b, integer *ldb, double *c__, double *d__, double *x, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cgglse_,zgglse_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(c), $P(d), $P(x), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgglse_,zgglse_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(c), $P(d), $P(x), work, &lwork, $P(info)); free(work); } '); pp_defc("ggglm", HandleBad => 0, Pars => '[phys]A(2,n,m); [phys]B(2,n,p);[phys]d(2,n);[o,phys]x(2,m);[o,phys]y(2,p);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cggglm_(integer *n, integer *m, integer *p, float * a, integer *lda, float *b, integer *ldb, float *d__, float *x, float *y, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zggglm_(integer *n, integer *m, integer *p, double * a, integer *lda, double *b, integer *ldb, double *d__, double *x, double *y, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cggglm_,zggglm_)( &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(d), $P(x), $P(y), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cggglm_,zggglm_)( &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(d), $P(x), $P(y), work, &lwork, $P(info)); free(work); } '); ################################################################################ # # COMPUTATIONAL LEVEL ROUTINES # ################################################################################ # TODO IPIV = min(m,n) pp_defc("getrf", HandleBad => 0, RedoDimsCode => '$SIZE(p) = $PDL(A)->ndims > 2 ? min($PDL(A)->dims[1], $PDL(A)->dims[2]) : 1;', Pars => '[io,phys]A(2,m,n); int [o,phys]ipiv(p); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' types(F) %{ extern int cgetrf_(integer *m, integer *n, float *a, integer * lda, integer *ipiv, integer *info); %} types(D) %{ extern int zgetrf_(integer *m, integer *n, double *a, integer * lda, integer *ipiv, integer *info); %} $TFD(cgetrf_,zgetrf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(ipiv), $P(info)); '); pp_defc("getf2", HandleBad => 0, RedoDimsCode => '$SIZE(p) = $PDL(A)->ndims > 2 ? min($PDL(A)->dims[1], $PDL(A)->dims[2]) : 1;', Pars => '[io,phys]A(2,m,n); int [o,phys]ipiv(p); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' types(F) %{ extern int cgetf2_(integer *m, integer *n, float *a, integer * lda, integer *ipiv, integer *info); %} types(D) %{ extern int zgetf2_(integer *m, integer *n, double *a, integer * lda, integer *ipiv, integer *info); %} $TFD(cgetf2_,zgetf2_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(ipiv), $P(info)); '); pp_defc("sytrf", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int csytrf_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zsytrf_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, double *work, integer *lwork, integer *info); double tmp_work[2]; %} if ($uplo()) puplo = \'L\'; $TFD(csytrf_,zsytrf_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(csytrf_,zsytrf_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), work, &lwork, $P(info)); free (work); } '); pp_defc("sytf2", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int csytf2_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, integer *info); %} types(D) %{ extern int zsytf2_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(csytf2_,zsytf2_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(info)); '); pp_defc("chetrf", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; integer lwork = -1; integer blocksiz; extern integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen opts_len); types(F) %{ extern int chetrf_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, float *work, integer *lwork, integer *info); float *work; blocksiz = ilaenv_(&c_nine, "CHETRF", " ", &c_zero, &c_zero, &c_zero, &c_zero, (ftnlen)6, (ftnlen)1); %} types(D) %{ extern int zhetrf_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, double *work, integer *lwork, integer *info); double *work; blocksiz = ilaenv_(&c_nine, "ZHETRF", " ", &c_zero, &c_zero, &c_zero, &c_zero, (ftnlen)6, (ftnlen)1); %} if ($uplo()) puplo = \'L\'; lwork = (integer ) $PRIV(__n_size) * blocksiz; types(F) %{ work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(chetrf_,zhetrf_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), work, &lwork, $P(info)); free (work); ', Doc=>' =for ref Complex version of sytrf for Hermitian matrix '); pp_defc("hetf2", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int chetf2_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, integer *info); %} types(D) %{ extern int zhetf2_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(chetf2_,zhetf2_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(info)); ', Doc=>' =for ref Complex version of sytf2 for Hermitian matrix '); pp_defc("potrf", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int cpotrf_(char *uplo, integer *n, float *a, integer * lda, integer *info); %} types(D) %{ extern int zpotrf_(char *uplo, integer *n, double *a, integer * lda, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(cpotrf_,zpotrf_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc=>' =for ref Complex version of potrf for Hermitian positive definite matrix '); pp_defc("potf2", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int cpotf2_(char *uplo, integer *n, float *a, integer * lda, integer *info); %} types(D) %{ extern int zpotf2_(char *uplo, integer *n, double *a, integer * lda, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(cpotf2_,zpotf2_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Complex version of potf2 for Hermitian positive definite matrix '); pp_defc("getri", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int [phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cgetri_(integer *n, float *a, integer *lda, integer *ipiv, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zgetri_(integer *n, double *a, integer *lda, integer *ipiv, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cgetri_,zgetri_)( &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(cgetri_,zgetri_)( &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), work, &lwork, $P(info)); free(work); } '); pp_defc("sytri", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int [phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int csytri_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, float *work, integer *info); float *work = (float *)malloc(2*$PRIV(__n_size) * sizeof(float)); %} types(D) %{ extern int zsytri_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, double *work, integer *info); double *work = (double *)malloc(2*$PRIV(__n_size) * sizeof(double)); %} if ($uplo()) puplo = \'L\'; $TFD(csytri_, zsytri_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), work, $P(info)); free(work); '); pp_defc("hetri", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int [phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int chetri_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, float *work, integer *info); float *work = (float *)malloc(2*$PRIV(__n_size) * sizeof(float)); %} types(D) %{ extern int zhetri_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, double *work, integer *info); double *work = (double *)malloc(2*$PRIV(__n_size) * sizeof(double)); %} if ($uplo()) puplo = \'L\'; $TFD(chetri_, zhetri_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), work, $P(info)); free(work); ', Doc => ' =for ref Complex version of sytri for Hermitian matrix '); pp_defc("potri", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int cpotri_(char *uplo, integer *n, float *a, integer * lda, integer *info); %} types(D) %{ extern int zpotri_(char *uplo, integer *n, double *a, integer * lda, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(cpotri_,zpotri_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); '); pp_defc("trtri", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int diag(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; char pdiag = \'N\'; types(F) %{ extern int ctrtri_(char *uplo, char *diag, integer *n, float *a, integer * lda, integer *info); %} types(D) %{ extern int ztrtri_(char *uplo, char *diag, integer *n, double *a, integer * lda, integer *info); %} if ($uplo()) puplo = \'L\'; if ($diag()) pdiag = \'U\'; $TFD(ctrtri_, ztrtri_)( &puplo, &pdiag, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); '); pp_defc("trti2", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int uplo(); int diag(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; char pdiag = \'N\'; types(F) %{ extern int ctrti2_(char *uplo, char *diag, integer *n, float *a, integer * lda, integer *info); %} types(D) %{ extern int ztrti2_(char *uplo, char *diag, integer *n, double *a, integer * lda, integer *info); %} if ($uplo()) puplo = \'L\'; if ($diag()) pdiag = \'U\'; $TFD(ctrti2_, ztrti2_)( &puplo, &pdiag, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); '); pp_defc("getrs", HandleBad => 0, Pars => '[phys]A(2,n,n); int trans(); [io,phys]B(2,n,m); int [phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char transp = \'N\'; types(F) %{ extern int cgetrs_(char *trans, integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer * ldb, integer *info); %} types(D) %{ extern int zgetrs_(char *trans, integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer * ldb, integer *info); %} if($trans() == 1) transp = \'T\'; else if($trans() == 2) transp = \'C\'; $TFD(cgetrs_,zgetrs_)( &transp, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc=>' =for ref Complex version of getrs Arguments ========= trans: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; '); pp_defc("sytrs", HandleBad => 0, Pars => '[phys]A(2,n,n); int uplo();[io,phys]B(2,n,m); int [phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int csytrs_(char *uplo, integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer * ldb, integer *info); %} types(D) %{ extern int zsytrs_(char *uplo, integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer * ldb, integer *info); %} if($uplo()) puplo = \'L\'; $TFD(csytrs_,zsytrs_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(info)); '); pp_defc("hetrs", HandleBad => 0, Pars => '[phys]A(2,n,n); int uplo();[io,phys]B(2,n,m); int [phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int chetrs_(char *uplo, integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer * ldb, integer *info); %} types(D) %{ extern int zhetrs_(char *uplo, integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer * ldb, integer *info); %} if($uplo()) puplo = \'L\'; $TFD(chetrs_,zhetrs_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Complex version of sytrs for Hermitian matrix '); pp_defc("potrs", HandleBad => 0, Pars => '[phys]A(2,n,n); int uplo(); [io,phys]B(2,n,m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int cpotrs_(char *uplo, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, integer * info); %} types(D) %{ extern int zpotrs_(char *uplo, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, integer * info); %} if($uplo()) puplo = \'L\'; $TFD(cpotrs_,zpotrs_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc=>' =for ref Complex version of potrs for Hermitian positive definite matrix '); pp_defc("trtrs", HandleBad => 0, Pars => '[phys]A(2,n,n); int uplo(); int trans(); int diag();[io,phys]B(2,n,m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; char ptrans = \'N\'; char pdiag = \'N\'; types(F) %{ extern int ctrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer * ldb, integer *info); %} types(D) %{ extern int ztrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer * ldb, integer *info); %} if($uplo()) puplo = \'L\'; if($trans() == 1) ptrans = \'T\'; else if($trans() == 2) ptrans = \'C\'; if($diag()) pdiag = \'U\'; $TFD(ctrtrs_,ztrtrs_)( &puplo, &ptrans, &pdiag, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc=>' =for ref Complex version of trtrs Arguments ========= trans: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; '); pp_defc("latrs", HandleBad => 0, Pars => '[phys]A(2,n,n); int uplo(); int trans(); int diag(); int normin();[io,phys]x(2,n); [o,phys]scale();[io,phys]cnorm(n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; char ptrans = \'N\'; char pdiag = \'N\'; char pnormin = \'N\'; types(F) %{ extern int clatrs_(char *uplo, char *trans, char *diag, char * normin, integer *n, float *a, integer *lda, float *x, float *scale, float *cnorm, integer *info); %} types(D) %{ extern int zlatrs_(char *uplo, char *trans, char *diag, char * normin, integer *n, double *a, integer *lda, double *x, double *scale, double *cnorm, integer *info); %} if($uplo()) puplo = \'L\'; if($trans()) ptrans = \'T\'; else if($trans() == 2) ptrans = \'C\'; if($diag()) pdiag = \'U\'; if($normin()) pnormin = \'Y\'; $TFD(clatrs_,zlatrs_)( &puplo, &ptrans, &pdiag, &pnormin, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(x), $P(scale), $P(cnorm), $P(info)); ', Doc=>' =for ref Complex version of latrs Arguments ========= trans: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; '); pp_defc("gecon", HandleBad => 0, Pars => '[phys]A(2,n,n); int norm(); [phys]anorm(); [o,phys]rcond();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pnorm = \'I\'; types(F) %{ extern int sgecon_(char *norm, integer *n, float *a, integer * lda, float *anorm, float *rcond, float *work, float * rwork, integer *info); float *work = (float *) malloc(($PRIV(__n_size) * 4) * sizeof(float)); float *rwork = (float *) malloc(($PRIV(__n_size) * 2)* sizeof(integer)); %} types(D) %{ extern int dgecon_(char *norm, integer *n, double *a, integer * lda, double *anorm, double *rcond, double *work, double * rwork, integer *info); double *work = (double *) malloc(($PRIV(__n_size)*4) * sizeof(double)); double *rwork = (double *) malloc(($PRIV(__n_size)*2 )* sizeof(integer)); %} if($norm()) pnorm = \'O\'; $TFD(sgecon_,dgecon_)( &pnorm, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(anorm), $P(rcond), work, rwork, $P(info)); free (work); free(rwork); '); pp_defc("sycon", HandleBad => 0, Pars => '[phys]A(2,n,n); int uplo(); int ipiv(n); [phys]anorm(); [o,phys]rcond();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int csycon_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, float *anorm, float *rcond, float * work, integer *info); float *work = (float *) malloc(($PRIV(__n_size) * 4) * sizeof(float)); %} types(D) %{ extern int zsycon_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, double *anorm, double *rcond, double * work, integer *info); double *work = (double *) malloc(($PRIV(__n_size)*4) * sizeof(double)); %} if($uplo()) puplo = \'L\'; $TFD(csycon_,zsycon_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(anorm), $P(rcond), work, $P(info)); free (work); '); pp_defc("hecon", HandleBad => 0, Pars => '[phys]A(2,n,n); int uplo(); int ipiv(n); [phys]anorm(); [o,phys]rcond();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int checon_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, float *anorm, float *rcond, float * work, integer *info); float *work = (float *) malloc(($PRIV(__n_size) * 4) * sizeof(float)); %} types(D) %{ extern int zhecon_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, double *anorm, double *rcond, double * work, integer *info); double *work = (double *) malloc(($PRIV(__n_size)*4) * sizeof(double)); %} if($uplo()) puplo = \'L\'; $TFD(checon_,zhecon_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(anorm), $P(rcond), work, $P(info)); free (work); ', Doc => ' =for ref Complex version of sycon for Hermitian matrix '); pp_defc("pocon", HandleBad => 0, Pars => '[phys]A(2,n,n); int uplo(); [phys]anorm(); [o,phys]rcond();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int cpocon_(char *uplo, integer *n, float *a, integer * lda, float *anorm, float *rcond, float *work, float * rwork, integer *info); float *work = (float *) malloc(($PRIV(__n_size) * 4) * sizeof(float)); float *rwork = (float *) malloc($PRIV(__n_size) * sizeof(integer)); %} types(D) %{ extern int zpocon_(char *uplo, integer *n, double *a, integer * lda, double *anorm, double *rcond, double *work, double * rwork, integer *info); double *work = (double *) malloc(($PRIV(__n_size)* 4) * sizeof(double)); double *rwork = (double *) malloc($PRIV(__n_size) * sizeof(integer)); %} if($uplo()) puplo = \'L\'; $TFD(cpocon_, zpocon_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(anorm), $P(rcond), work, rwork, $P(info)); free (work); free(rwork); ', Doc => ' =for ref Complex version of pocon for Hermitian positive definite matrix '); pp_defc("trcon", HandleBad => 0, Pars => '[phys]A(2,n,n); int norm();int uplo();int diag(); [o,phys]rcond();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; char pdiag = \'N\'; char pnorm = \'I\'; types(F) %{ extern int strcon_(char *norm, char *uplo, char *diag,integer *n, float *a, integer * lda, float *rcond, float *work, float *rwork, integer *info); float *work = (float *) malloc(($PRIV(__n_size) * 4) * sizeof(float)); float *rwork = (float *) malloc($PRIV(__n_size) * sizeof(integer)); %} types(D) %{ extern int dtrcon_(char *norm, char *uplo, char *diag, integer *n, double *a, integer * lda, double *rcond, double * work, double *rwork, integer *info); double *work = (double *) malloc(($PRIV(__n_size)* 4) * sizeof(double)); double *rwork = (double *) malloc($PRIV(__n_size) * sizeof(integer)); %} if($uplo()) puplo = \'L\'; if($diag()) pdiag = \'U\'; if($norm()) pnorm = \'O\'; $TFD(strcon_,dtrcon_)( &pnorm, &puplo, &pdiag, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(rcond), work, rwork, $P(info)); free (work); free(rwork); '); pp_defc("geqp3", HandleBad => 0, Pars => '[io,phys]A(2,m,n); int [io,phys]jpvt(n); [o,phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cgeqp3_(integer *m, integer *n, float *a, integer * lda, integer *jpvt, float *tau, float *work, integer *lwork, float *rwork, integer *info); float tmp_work[2], *rwork; rwork = (float *) malloc ($PRIV(__n_size) * 2 * sizeof(float)); %} types(D) %{ extern int zgeqp3_(integer *m, integer *n, double *a, integer * lda, integer *jpvt, double *tau, double *work, integer *lwork, double *rwork, integer *info); double tmp_work[2], *rwork; rwork = (double *) malloc ($PRIV(__n_size) * 2 * sizeof(double)); %} $TFD(cgeqp3_,zgeqp3_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(jpvt), $P(tau), &tmp_work[0], &lwork, rwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgeqp3_,zgeqp3_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(jpvt), $P(tau), work, &lwork, rwork, $P(info)); free(work); } free(rwork); ' ); pp_defc("geqrf", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [o,phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cgeqrf_(integer *m, integer *n, float *a, integer * lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zgeqrf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cgeqrf_,zgeqrf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgeqrf_,zgeqrf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } '); pp_defc("ungqr", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cungqr_(integer *m, integer *n, integer *k, float * a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zungqr_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cungqr_, zungqr_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cungqr_,zungqr_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Complex version of orgqr '); pp_defc("unmqr", HandleBad => 0, Pars => '[phys]A(2,p,k); int side(); int trans(); [phys]tau(2,k); [io,phys]C(2,m,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\', pside = \'L\'; integer lwork = -1; types(F) %{ extern int cunmqr_(char *side, char *trans, integer *m, integer *n, integer *k, float *a, integer *lda, float *tau, float * c__, integer *ldc, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zunmqr_(char *side, char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); double tmp_work[2]; %} if($trans()) ptrans = \'C\'; if($side()) pside = \'R\'; $TFD(cunmqr_,zunmqr_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__p_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cunmqr_,zunmqr_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__p_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Complex version of ormqr. Here trans = 1 means conjugate transpose. '); pp_defc("gelqf", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [o,phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cgelqf_(integer *m, integer *n, float *a, integer * lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zgelqf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cgelqf_,zgelqf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgelqf_,zgelqf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } '); pp_defc("unglq", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cunglq_(integer *m, integer *n, integer *k, float * a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zunglq_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cunglq_,zunglq_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cunglq_,zunglq_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Complex version of orglq '); pp_defc("unmlq", HandleBad => 0, Pars => '[phys]A(2,k,p); int side(); int trans(); [phys]tau(2,k); [io,phys]C(2,m,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\', pside = \'L\'; integer lwork = -1; types(F) %{ extern int cunmlq_(char *side, char *trans, integer *m, integer *n, integer *k, float *a, integer *lda, float *tau, float * c__, integer *ldc, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zunmlq_(char *side, char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); double tmp_work[2]; %} if($trans()) ptrans = \'C\'; if($side()) pside = \'R\'; $TFD(cunmlq_,zunmlq_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cunmlq_,zunmlq_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Complex version of ormlq. Here trans = 1 means conjugate transpose. '); pp_defc("geqlf", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [o,phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cgeqlf_(integer *m, integer *n, float *a, integer * lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zgeqlf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cgeqlf_,zgeqlf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgeqlf_,zgeqlf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } '); pp_defc("ungql", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cungql_(integer *m, integer *n, integer *k, float * a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zungql_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cungql_,zungql_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cungql_,zungql_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Complex version of orgql. '); pp_defc("unmql", HandleBad => 0, Pars => '[phys]A(2,p,k); int side(); int trans(); [phys]tau(2,k); [io,phys]C(2,m,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\', pside = \'L\'; integer lwork = -1; types(F) %{ extern int cunmql_(char *side, char *trans, integer *m, integer *n, integer *k, float *a, integer *lda, float *tau, float * c__, integer *ldc, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zunmql_(char *side, char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); double tmp_work[2]; %} if($trans()) ptrans = \'C\'; if($side()) pside = \'R\'; $TFD(cunmql_,zunmql_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__p_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cunmql_,zunmql_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__p_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Complex version of ormql. Here trans = 1 means conjugate transpose. '); pp_defc("gerqf", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [o,phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cgerqf_(integer *m, integer *n, float *a, integer * lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zgerqf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cgerqf_,zgerqf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cgerqf_,zgerqf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } '); pp_defc("ungrq", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cungrq_(integer *m, integer *n, integer *k, float * a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zungrq_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cungrq_,zungrq_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cungrq_,zungrq_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Complex version of orgrq. '); pp_defc("unmrq", HandleBad => 0, Pars => '[phys]A(2,k,p); int side(); int trans(); [phys]tau(2,k); [io,phys]C(2,m,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\', pside = \'L\'; integer lwork = -1; types(F) %{ extern int cunmrq_(char *side, char *trans, integer *m, integer *n, integer *k, float *a, integer *lda, float *tau, float * c__, integer *ldc, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zunmrq_(char *side, char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); double tmp_work[2]; %} if($trans()) ptrans = \'C\'; if($side()) pside = \'R\'; $TFD(cunmrq_,zunmrq_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cunmrq_,zunmrq_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Complex version of ormrq. Here trans = 1 means conjugate transpose. '); pp_defc("tzrzf", HandleBad => 0, Pars => '[io,phys]A(2,m,n); [o,phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int ctzrzf_(integer *m, integer *n, float *a, integer * lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int ztzrzf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(ctzrzf_,ztzrzf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(ctzrzf_,ztzrzf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } '); pp_defc("unmrz", HandleBad => 0, Pars => '[phys]A(2,k,p); int side(); int trans(); [phys]tau(2,k); [io,phys]C(2,m,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\', pside = \'L\'; integer lwork = -1; integer kk = $SIZE(p) - $SIZE(k); types(F) %{ extern int cunmrz_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, float *a, integer *lda, float *tau, float * c__, integer *ldc, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zunmrz_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); double tmp_work[2]; %} if($trans()) ptrans = \'C\'; if($side()) pside = \'R\'; $TFD(cunmrz_,zunmrz_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, &kk, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(cunmrz_,zunmrz_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, &kk, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Complex version of ormrz. Here trans = 1 means conjugate transpose. '); pp_defc("gehrd", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int [phys]ilo();int [phys]ihi();[o,phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cgehrd_(integer *n, integer *ilo, integer *ihi, float *a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zgehrd_(integer *n, integer *ilo, integer *ihi, double *a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cgehrd_,zgehrd_)( &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(A), &(integer){$PRIV(__n_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(cgehrd_,zgehrd_)( &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(A), &(integer){$PRIV(__n_size)}, $P(tau), work, &lwork, $P(info)); free(work); } '); pp_defc("unghr", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int [phys]ilo();int [phys]ihi();[phys]tau(2,k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int cunghr_(integer *n, integer *ilo, integer *ihi, float *a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zunghr_(integer *n, integer *ilo, integer *ihi, double *a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work[2]; %} $TFD(cunghr_,zunghr_)( &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(A), &(integer){$PRIV(__n_size)}, $P(tau), &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2*lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2*lwork * sizeof(double)); %} $TFD(cunghr_,zunghr_)( &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(A), &(integer){$PRIV(__n_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc=>' =for ref Complex version of orghr '); pp_defc("hseqr", HandleBad => 0, Pars => '[io,phys]H(2,n,n); int job();int compz();int [phys]ilo();int [phys]ihi();[o,phys]w(2,n); [o,phys]Z(2,m,m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pcompz; char pjob = \'E\'; integer lwork = -1; types(F) %{ extern int chseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, float *h__, integer *ldh, float *w, float *z__, integer *ldz, float *work, integer *lwork, integer *info); float tmp_work[2]; %} types(D) %{ extern int zhseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, double *h__, integer *ldh, double *w, double *z__, integer *ldz, double *work, integer *lwork, integer *info); double tmp_work[2]; %} if($job()) pjob = \'S\'; switch ($compz()) { case 1: pcompz = \'I\'; break; case 2: pcompz = \'V\'; break; default: pcompz = \'N\'; } $TFD(chseqr_,zhseqr_)( &pjob, &pcompz, &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(H), &(integer){$PRIV(__n_size)}, $P(w), $P(Z), &(integer){$PRIV(__m_size)}, &tmp_work[0], &lwork, $P(info)); lwork = (integer )tmp_work[0]; { types(F) %{ float *work = (float *)malloc(2 * lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(2 * lwork * sizeof(double)); %} $TFD(chseqr_,zhseqr_)( &pjob, &pcompz, &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(H), &(integer){$PRIV(__n_size)}, $P(w), $P(Z), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } '); pp_defc("trevc", HandleBad => 0, Pars => '[io,phys]T(2,n,n); int side();int howmny();int [phys]select(q);[io,phys]VL(2,m,r); [io,phys]VR(2,p,s);int [o,phys]m(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pside,phowmny; integer mm = 0; types(F) %{ extern int ctrevc_(char *side, char *howmny, logical *select, integer *n, float *t, integer *ldt, float *vl, integer * ldvl, float *vr, integer *ldvr, integer *mm, integer *m, float *work, float *rwork, integer *info); float *work = (float *) malloc(5 * $SIZE(n) *sizeof(float)); %} types(D) %{ extern int ztrevc_(char *side, char *howmny, logical *select, integer *n, double *t, integer *ldt, double *vl, integer * ldvl, double *vr, integer *ldvr, integer *mm, integer *m, double *work, double *rwork, integer *info); double *work = (double *) malloc (5 * $SIZE(n) * sizeof(double)); %} switch ($howmny()) { case 1: phowmny = \'B\'; break; case 2: phowmny = \'S\'; break; default: phowmny = \'A\'; } switch ($side()) { case 1: pside = \'R\'; mm = $SIZE(s); break; case 2: pside = \'L\'; mm = $SIZE(r); break; default:pside = \'B\'; mm = $SIZE(s); } $TFD(ctrevc_,ztrevc_)( &pside, &phowmny, $P(select), &(integer){$PRIV(__n_size)}, $P(T), &(integer){$PRIV(__n_size)}, $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, &mm, $P(m), &work[$SIZE(n)], work, $P(info)); free(work); '); pp_defc("tgevc", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int side();int howmny(); [io,phys]B(2,n,n);int [phys]select(q);[io,phys]VL(2,m,r); [io,phys]VR(2,p,s);int [o,phys]m(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pside,phowmny; integer mm = 0; types(F) %{ extern int ctgevc_(char *side, char *howmny, logical *select, integer *n, float *a, integer *lda, float *b, integer *ldb, float *vl, integer *ldvl, float *vr, integer *ldvr, integer *mm, integer *m, float *work, float *rwork, integer *info); float *work = (float *) malloc(6 * $SIZE(n) *sizeof(float)); %} types(D) %{ extern int ztgevc_(char *side, char *howmny, logical *select, integer *n, double *a, integer *lda, double *b, integer *ldb, double *vl, integer *ldvl, double *vr, integer *ldvr, integer *mm, integer *m, double *work, double *rwork, integer *info); double *work = (double *) malloc (6 * $SIZE(n) * sizeof(double)); %} switch ($howmny()) { case 1: phowmny = \'B\'; break; case 2: phowmny = \'S\'; break; default: phowmny = \'A\'; } switch ($side()) { case 1: pside = \'R\'; mm = $SIZE(s); break; case 2: pside = \'L\'; mm = $SIZE(r); break; default:pside = \'B\'; mm = $SIZE(s); } $TFD(ctgevc_,ztgevc_)( &pside, &phowmny, $P(select), &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, &mm, $P(m), &work[2*$SIZE(n)], work, $P(info)); free(work); '); pp_defc("gebal", HandleBad => 0, Pars => '[io,phys]A(2,n,n); int job(); int [o,phys]ilo();int [o,phys]ihi();[o,phys]scale(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pjob; types(F) %{ extern int cgebal_(char *job, integer *n, float *a, integer * lda, integer *ilo, integer *ihi, float *scale, integer *info); %} types(D) %{ extern int zgebal_(char *job, integer *n, double *a, integer * lda, integer *ilo, integer *ihi, double *scale, integer *info); %} switch ($job()) { case 1: pjob = \'P\'; break; case 2: pjob = \'S\'; break; case 3: pjob = \'B\'; break; default: pjob = \'N\'; } $TFD(cgebal_,zgebal_)( &pjob, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(scale), $P(info)); '); ################################################################################# pp_defc("lange", HandleBad => 0, Pars => '[phys]A(2,n,m); int norm(); [o]b()', GenericTypes => [F,D], Code => ' char pnorm; types(F) %{ extern float clange_(char *norm, integer *m, integer *n, float *a, integer *lda, float *work); float *work; %} types(D) %{ extern double zlange_(char *norm, integer *m, integer *n, double *a, integer *lda, double *work); double *work; %} switch ($norm()) { case 1: pnorm = \'O\'; break; case 2: pnorm = \'I\'; types(F) %{ work = (float *)malloc($PRIV(__n_size) * sizeof(float)); %} types(D) %{ work = (double *)malloc($PRIV(__n_size) * sizeof(double)); %} break; case 3: pnorm = \'F\'; break; default: pnorm = \'M\'; } $b() = $TFD(clange_,zlange_)( &pnorm, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, work); if ($norm() == 2) free (work); '); pp_defc("lansy", HandleBad => 0, Pars => '[phys]A(2, n,n); int uplo(); int norm(); [o]b()', GenericTypes => [F,D], Code => ' char pnorm, puplo = \'U\'; types(F) %{ extern float clansy_(char *norm, char *uplo, integer *n, float *a, integer *lda, float *work); float *work; %} types(D) %{ extern double zlansy_(char *norm, char *uplo, integer *n, double *a, integer *lda, double *work); double *work; %} switch ($norm()) { case 1: pnorm = \'O\'; types(F) %{ work = (float *)malloc($PRIV(__n_size) * sizeof(float)); %} types(D) %{ work = (double *)malloc($PRIV(__n_size) * sizeof(double)); %} break; case 2: pnorm = \'I\'; types(F) %{ work = (float *)malloc($PRIV(__n_size) * sizeof(float)); %} types(D) %{ work = (double *)malloc($PRIV(__n_size) * sizeof(double)); %} break; case 3: pnorm = \'F\'; break; default: pnorm = \'M\'; } if($uplo()) puplo = \'L\'; $b() = $TFD(clansy_,zlansy_)( &pnorm, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, work); if ($norm() == 2 || $norm() == 1) free (work); '); pp_defc("lantr", HandleBad => 0, Pars => '[phys]A(2,m,n);int uplo();int norm();int diag();[o]b()', GenericTypes => [F,D], Code => ' char pnorm, puplo = \'U\'; char pdiag = \'N\'; types(F) %{ extern float clantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, float *a, integer *lda, float *work); float *work; %} types(D) %{ extern double zlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, double *a, integer *lda, double *work); double *work; %} switch ($norm()) { case 1: pnorm = \'O\'; break; case 2: pnorm = \'I\'; types(F) %{ work = (float *)malloc($PRIV(__m_size) * sizeof(float)); %} types(D) %{ work = (double *)malloc($PRIV(__m_size) * sizeof(double)); %} break; case 3: pnorm = \'F\'; break; default: pnorm = \'M\'; } if($uplo()) puplo = \'L\'; if($diag()) pdiag = \'U\'; $b() = $TFD(clantr_,zlantr_)( &pnorm, &puplo, &pdiag, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, work); if ($norm() == 2) free (work); '); ################################################################################ # # BLAS ROUTINES # ################################################################################ pp_defc("gemm", HandleBad => 0, Pars => '[phys]A(2,m,n); int transa(); int transb(); [phys]B(2,p,q);[phys]alpha(2); [phys]beta(2); [io,phys]C(2,r,s)', GenericTypes => [F,D], Code => ' char ptransa = \'N\'; char ptransb = \'N\'; types(F) %{ extern int cgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, float *alpha, float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); %} types(D) %{ extern int zgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, double *alpha, double *a, integer *lda, double *b, integer *ldb, double *beta, double *c__, integer *ldc); %} integer kk = $transa() ? $SIZE(m) : $SIZE(n); if ($transa() == 1) ptransa = \'T\'; else if ($transa() == 2) ptransa = \'C\'; if ($transb()) ptransb = \'T\'; else if ($transb() == 2) ptransb = \'C\'; $TFD(cgemm_,zgemm_)( &ptransa, &ptransb, &(integer){$PRIV(__r_size)}, &(integer){$PRIV(__s_size)}, &kk, $P(alpha), $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(beta), $P(C), &(integer){$PRIV(__r_size)}); ', Doc=>' =for ref Complex version of gemm. Arguments ========= transa: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; transb: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; '); if ($config{CBLAS}){ pp_def("rmcgemm", HandleBad => 0, Pars => '[phys]A(2,m,n); int transa(); int transb(); [phys]B(2,p,q);[phys]alpha(2); [phys]beta(2); [io,phys]C(2,r,s)', GenericTypes => [F,D], Code => ' int ptransa, ptransb; types(F) %{ extern void cblas_cgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_TRANSPOSE TransB, const int M, const int N, const int K, const void *alpha, const void *A, const int lda, const void *B, const int ldb, const void *beta, void *C, const int ldc); %} types(D) %{ extern void cblas_zgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_TRANSPOSE TransB, const int M, const int N, const int K, const void *alpha, const void *A, const int lda, const void *B, const int ldb, const void *beta, void *C, const int ldc); %} integer kk = $transa() ? $SIZE(n) : $SIZE(m); switch($transa()){ case 1: ptransa = CblasTrans; break; case 2: ptransa = CblasConjTrans; break; default:ptransa = CblasNoTrans; } switch($transb()){ case 1: ptransb = CblasTrans; break; case 2: ptransb = CblasConjTrans; break; default:ptransb = CblasNoTrans; } $TFD(cblas_cgemm,cblas_zgemm)( CblasRowMajor, ptransa, ptransb, $PRIV(__s_size), $PRIV(__r_size), kk, $P(alpha), $P(A), $PRIV(__m_size), $P(B), $PRIV(__p_size), $P(beta), $P(C), $PRIV(__r_size)); ', Doc=>' =for ref Complex version of rmgemm. Arguments ========= transa: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; transb: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; '); } pp_defc("mmult", HandleBad => 0, Pars => '[phys]A(2,m,n); [phys]B(2,p,m); [o,phys]C(2,p,n)', GenericTypes => [F,D], Code => ' char ptrans = \'N\'; types(F) %{ extern int cgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, float *alpha, float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); float alpha[2] = {1,0}; float beta[2] = {0,0}; %} types(D) %{ extern int zgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, double *alpha, double *a, integer *lda, double *b, integer *ldb, double *beta, double *c__, integer *ldc); double alpha[2] = {1,0}; double beta[2] = {0,0}; %} $TFD(cgemm_,zgemm_)( &ptrans, &ptrans, &(integer){$PRIV(__p_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, &alpha[0], $P(B), &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__m_size)}, &beta[0], $P(C), &(integer){$PRIV(__p_size)}); '); if ($config{STRASSEN}){ pp_defc("smmult", HandleBad => 0, Pars => '[phys]A(2,m,n); [phys]B(2,p,m); [o,phys]C(2,p,n)', GenericTypes => [F,D], Code => ' char ptrans = \'N\'; types(F) %{ extern int cgemmb_(char *transa, char *transb, integer *m, integer * n, integer *k, float *alpha, float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); float alpha[2] = {1,0}; float beta[2] = {0,0}; %} types(D) %{ extern int zgemmb_(char *transa, char *transb, integer *m, integer * n, integer *k, double *alpha, double *a, integer *lda, double *b, integer *ldb, double *beta, double *c__, integer *ldc); double alpha[2] = {1,0}; double beta[2] = {0,0}; %} $TFD(cgemmb_,zgemmb_)( &ptrans, &ptrans, &(integer){$PRIV(__p_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, &alpha[0], $P(B), &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__m_size)}, &beta[0], $P(C), &(integer){$PRIV(__p_size)}); '); } pp_defc("crossprod", HandleBad => 0, Pars => '[phys]A(2,n,m); [phys]B(2,p,m); [o,phys]C(2,p,n)', GenericTypes => [F,D], Code => ' char btrans = \'N\'; char atrans = \'C\'; types(F) %{ extern int cgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, float *alpha, float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); float alpha[2] = {1,0}; float beta[2] = {0,0}; %} types(D) %{ extern int zgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, double *alpha, double *a, integer *lda, double *b, integer *ldb, double *beta, double *c__, integer *ldc); double alpha[2] = {1,0}; double beta[2] = {0,0}; %} $TFD(cgemm_,zgemm_)( &btrans, &atrans, &(integer){$PRIV(__p_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, &alpha[0], $P(B), &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__n_size)}, &beta[0], $P(C), &(integer){$PRIV(__p_size)}); '); pp_defc("syrk", HandleBad => 0, Pars => '[phys]A(2,m,n); int uplo(); int trans(); [phys]alpha(2); [phys]beta(2); [io,phys]C(2,p,p)', RedoDimsCode => '$SIZE(p) = $trans() ? $SIZE(n) : $SIZE(m);', GenericTypes => [F,D], Code => ' char puplo = \'U\'; char ptrans = \'N\'; types(F) %{ extern int csyrk_(char *uplo, char *trans, integer *n, integer *k, float *alpha, float *a, integer *lda, float *beta, float *c__, integer *ldc); %} types(D) %{ extern int zsyrk_(char *uplo, char *trans, integer *n, integer *k, double *alpha, double *a, integer *lda, double *beta, double *c__, integer *ldc); %} integer kk = $trans() ? $SIZE(m) : $SIZE(n); if ($uplo()) puplo = \'L\'; if ($trans()) ptrans = \'T\'; $TFD(csyrk_,zsyrk_)( &puplo, &ptrans, &(integer){$PRIV(__p_size)}, &kk, $P(alpha), $P(A), &(integer){$PRIV(__m_size)}, $P(beta), $P(C), &(integer){$PRIV(__p_size)}); '); if ($config{CBLAS}){ pp_def("rmcsyrk", HandleBad => 0, Pars => '[phys]A(2,m,n); int uplo(); int trans(); [phys]alpha(2); [phys]beta(2); [io,phys]C(2,p,p)', GenericTypes => [F,D], Code => ' int puplo = CblasUpper; int ptrans; types(F) %{ extern void cblas_csyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE Trans, const int N, const int K, const void *alpha, const void *A, const int lda, const void *beta, void *C, const int ldc); %} types(D) %{ extern void cblas_zsyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE Trans, const int N, const int K, const void *alpha, const void *A, const int lda, const void *beta, void *C, const int ldc); %} integer kk = $trans() ? $SIZE(n) : $SIZE(m); if ($uplo()) puplo = CblasLower; switch($trans()){ case 1: ptrans = CblasTrans; break; case 2: ptrans = CblasConjTrans; break; default:ptrans = CblasNoTrans; } $TFD(cblas_csyrk,cblas_zsyrk)( CblasRowMajor, puplo, ptrans, $PRIV(__p_size), kk, $P(alpha), $P(A), $PRIV(__m_size), $P(beta), $P(C), $PRIV(__p_size)); ', Doc=>' =for ref Complex version of rmsyrk '); } pp_defc("dot", HandleBad => 0, Pars => '[phys]a(2,n);int [phys]inca();[phys]b(2,n);int [phys]incb();[o,phys]c(2)', GenericTypes => [F,D], Code => ' types(F) %{ extern float cdotu_(float *ret, integer *n, float *dx, integer *incx, float *dy, integer *incy); %} types(D) %{ extern double zdotu_(double *ret, integer *n, double *dx, integer *incx, double *dy, integer *incy); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $TFD(cdotu_,zdotu_)( $P(c), &n, $P(a), $P(inca), $P(b), $P(incb)); '); pp_def("cdotc", HandleBad => 0, Pars => '[phys]a(2,n);int [phys]inca();[phys]b(2,n);int [phys]incb();[o,phys]c(2)', GenericTypes => [F,D], Code => ' types(F) %{ extern float cdotc_(float *ret, integer *n, float *dx, integer *incx, float *dy, integer *incy); %} types(D) %{ extern double zdotc_(double *ret, integer *n, double *dx, integer *incx, double *dy, integer *incy); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $TFD(cdotc_,zdotc_)( $P(c), &n, $P(a), $P(inca), $P(b), $P(incb)); ', Doc=>' =for ref Forms the dot product of two vectors, conjugating the first vector. '); pp_defc("axpy", HandleBad => 0, Pars => '[phys]a(2,n);int [phys]inca();[phys] alpha(2);[io,phys]b(2,n);int [phys]incb()', GenericTypes => [F,D], Code => ' types(F) %{ extern int caxpy_(integer *n, float *da, float *dx, integer *incx, float *dy, integer *incy); %} types(D) %{ extern int zaxpy_(integer *n, double *da, double *dx, integer *incx, double *dy, integer *incy); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $TFD(caxpy_,zaxpy_)( &n, $P(alpha), $P(a), $P(inca), $P(b), $P(incb)); '); pp_defc("nrm2", HandleBad => 0, Pars => '[phys]a(2,n);int [phys]inca();[o,phys]b()', GenericTypes => [F,D], Code => ' types(F) %{ extern float scnrm2_(integer *n, float *dx, integer *incx); %} types(D) %{ extern double dznrm2_(integer *n, double *dx, integer *incx); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $b() = $TFD(scnrm2_,dznrm2_)( &n, $P(a), $P(inca)); '); pp_defc("asum", HandleBad => 0, Pars => '[phys]a(2,n);int [phys]inca();[o,phys]b()', GenericTypes => [F,D], Code => ' types(F) %{ extern float scasum_(integer *n, float *dx, integer *incx); %} types(D) %{ extern double dzasum_(integer *n, double *dx, integer *incx); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $b() = $TFD(scasum_,dzasum_)( &n, $P(a), $P(inca)); '); pp_defc("scal", HandleBad => 0, Pars => '[io,phys]a(2,n);int [phys]inca();[phys]scale(2)', GenericTypes => [F,D], Code => ' types(F) %{ extern int cscal_(integer *n, float *sa, float *dx, integer *incx); %} types(D) %{ extern int zscal_(integer *n, double *sa, double *dx,integer *incx); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $TFD(cscal_,zscal_)( &n, $P(scale), $P(a), $P(inca)); '); pp_def("sscal", HandleBad => 0, Pars => '[io,phys]a(2,n);int [phys]inca();[phys]scale()', GenericTypes => [F], Code => ' extern int csscal_(integer *n, float *sa, float *dx, integer *incx); integer n = (integer ) $PRIV(__n_size)/$inca(); csscal_( &n, $P(scale), $P(a), $P(inca)); ', Doc=>' =for ref Scales a complex vector by a real constant. '); pp_defc("rotg", HandleBad => 0, Pars => '[io,phys]a(2);[phys]b(2);[o,phys]c(); [o,phys]s(2)', GenericTypes => [F,D], Code => ' types(F) %{ extern int crotg_(float *dx, float *dy, float *c, float *s); %} types(D) %{ extern int zrotg_(double *dx, double *dy, double *c, double *s); %} $TFD(crotg_,zrotg_)( $P(a), $P(b), $P(c), $P(s) ); '); ################################################################################ # # LAPACK AUXILIARY ROUTINES # ################################################################################ pp_defc("lacpy", HandleBad => 0, Pars => '[phys]A(2,m,n); int uplo(); [o,phys]B(2,p,n)', GenericTypes => [F,D], Code => ' char puplo; types(F) %{ extern int clacpy_(char *uplo, integer *m, integer *n, float * a, integer *lda, float *b, integer *ldb); %} types(D) %{ extern int zlacpy_(char *uplo, integer *m, integer *n, double * a, integer *lda, double *b, integer *ldb); %} switch ($uplo()) { case 0: puplo = \'U\'; break; case 1: puplo = \'L\'; break; default: puplo = \'A\'; } $TFD(clacpy_,zlacpy_)( &puplo, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}); '); pp_defc("laswp", HandleBad => 0, Pars => '[io,phys]A(2,m,n); int [phys]k1(); int [phys]k2(); int [phys]ipiv(p);int [phys]inc()', GenericTypes => [F,D], Code => ' types(F) %{ extern int claswp_(integer *n, float *a, integer *lda, integer *k1, integer *k2, integer *ipiv, integer *incx); %} types(D) %{ extern int zlaswp_(integer *n, double *a, integer *lda, integer *k1, integer *k2, integer *ipiv, integer *incx); %} $TFD(claswp_,zlaswp_)( &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(k1), $P(k2), $P(ipiv), $P(inc)); '); ################################################################################ # # OTHER AUXILIARY ROUTINES # ################################################################################ pp_def( 'ctricpy', Pars => 'A(c=2,m,n);int uplo();[o] C(c=2,m,n)', Code => ' PDL_Long i, j, k; if ($uplo()) { for (i = 0; i < $SIZE(n);i++) { k = min(i,($SIZE(m)-1)); for (j = 0; j <= k; j++) { $C(c=>0,m=>j,n=>i) = $A(c=>0,m=>j,n=>i); $C(c=>1,m=>j,n=>i) = $A(c=>1,m=>j,n=>i); } } } else { for (i = 0; i < $SIZE(n);i++) { for (j = i; j < $SIZE(m); j++) { $C(c=>0,m=>j,n=>i) = $A(c=>0,m=>j,n=>i); $C(c=>1,m=>j,n=>i) = $A(c=>1,m=>j,n=>i); } if (i >= $SIZE(m)) break; } } ', Doc => < 1, Reversible => 1, Pars => 'x(c,n,m);y(c,n,p);[o]out(c,n,q);', RedoDimsCode => '$SIZE(q) = $PDL(x)->dims[2] + $PDL(y)->dims[2];', Code => ' register PDL_Long i,j; loop(m)%{ loop(n)%{ loop(c)%{ $out(c=>c,n=>n,q=>m) = $x(c=>c,n=>n,m=>m); %} %} %} j=0; for (i = $SIZE(m); i < $SIZE(q) ;i++,j++) { loop(n)%{ loop(c)%{ $out(c=>c,n=>n,q=>i) = $y(c=>c,n=>n,p=>j); %} %} } ', BackCode => ' register PDL_Long i,j; loop(m)%{ loop(n)%{ loop(c)%{ $x(c=>c,n=>n,m=>m) = $out(c=>c,n=>n,q=>m); %} %} %} j=0; for (i = $SIZE(m); i < $SIZE(q) ;i++,j++) { loop(n)%{ loop(c)%{ $y(c=>c,n=>n,p=>j) = $out(c=>c,n=>n,q=>i); %} %} } ', Doc => < '$SIZE(p) = $PDL(A)->dims[1] + 1;', Pars => '[phys]A(c=2,n,n);[phys,o]Y(c=2,n,n);[phys,o]out(c=2,p);', GenericTypes => [F,D], Code => ' int i,j,k; $GENERIC() *p, tr[2], b[2]; //$GENERIC() *tmp; char ptrans = \'N\'; types(F) %{ extern int cgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, float *alpha, float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); float alpha[2] = {1,0}; float beta[2] = {0,0}; %} types(D) %{ extern int zgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, double *alpha, double *a, integer *lda, double *b, integer *ldb, double *beta, double *c__, integer *ldc); double alpha[2] = {1,0}; double beta[2] = {0,0}; %} p = ($GENERIC() * ) malloc (2* $SIZE(n) * $SIZE(n) * sizeof($GENERIC())); loop(n0)%{ loop(n1)%{ $Y(c=>0,n0=>n0,n1=>n1) = (n0 == n1) ? ($GENERIC()) 1.0 : ($GENERIC()) 0.0; $Y(c=>1,n0=>n0,n1=>n1) = ($GENERIC()) 0.0; %} %} $out(c=>0,p=>0) = 1; $out(c=>1,p=>0) = 0; i = 0; for (;;) { i++; $TFD(cgemm_,zgemm_)(&ptrans,&ptrans,&(integer){$PRIV(__n_size)},&(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)},&alpha[0],$P(Y),&(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, &beta[0], p, &(integer){$PRIV(__n_size)}); if (i == $SIZE(n)) break; // if (k+1) & 1 without the copy below => return diagonal matrix // with determinant (on my 5-year-old-pentium (windows)) !!!??? // tmp = $P(Y); // $P(Y) = p; // p = tmp; memmove($P(Y), p, 2* $SIZE(n) * $SIZE(n) * sizeof($GENERIC())); // loop(n1) // %{ // loop(n0) // %{ // $Y(c=>0,n0=>n0,n1=>n1) = p[((n1*$SIZE(n))+n0)*2]; // $Y(c=>1,n0=>n0,n1=>n1) = p[((n1*$SIZE(n))+n0)*2+1]; // %} // %} $TFD(cftrace,cdtrace)($SIZE(n), $P(Y), &tr[0]); b[0] = $out(c=>0,p=>i) = - tr[0] / i; b[1] = $out(c=>1,p=>i) = - tr[1] / i; for (j = 0; j < $SIZE(n); j++) { $Y(c=>0,n0=>j,n1=>j) += b[0]; $Y(c=>1,n0=>j,n1=>j) += b[1]; } } k = $SIZE(n); $TFD(cftrace,cdtrace)(k, p, &tr[0]); $out(c=>0,p=>k) = - tr[0] / k; $out(c=>1,p=>k) = - tr[1] / k; if ((k+1) & 1) { loop(n0) %{ loop(n1) %{ $Y(c=>0,n0=>n0,n1=>n1) = -$Y(c=>0,n0=>n0,n1=>n1); $Y(c=>1,n0=>n0,n1=>n1) = -$Y(c=>1,n0=>n0,n1=>n1); %} %} } free(p); ' ); pp_addpm({At=>'Bot'},<<'EOD'); =head1 AUTHOR Copyright (C) Grégory Vanuxem 2005-2007. This library is free software; you can redistribute it and/or modify it under the terms of the artistic license as specified in the Artistic file. =cut EOD pp_done(); # you will need this to finish pp processing PDL-LinearAlgebra-0.12/Complex/Makefile.PL0000755113142400244210000000273012535324524022352 0ustar chris.h.marshallDomain Users # Use this as a template for the Makefile.PL for # any external PDL module. use ExtUtils::MakeMaker; use PDL::Core::Dev; use Config; @pack = (["complex.pd",Complex, PDL::LinearAlgebra::Complex]); %hash = pdlpp_stdargs(@::pack); # $hash{'OPTIMIZE'} = '-g'; # If you want to debug, uncomment this. #$hash{LIBS}[0] .= $^O =~ /MSWin/ ? '' : '-lacml -lgfortran '; #$hash{LIBS}[0] .= $^O =~ /MSWin/ ? '' : '-L/usr/lib/atlas -llapack -lblas -latlas '; #$hash{'OPTIMIZE'} = '-O2 -mtune=k8'; # If you want to debug, uncomment this. $hash{LIBS}[0] .= ( eval {require PkgConfig; join ' ', PkgConfig->find('lapack')->get_ldflags} || eval {require ExtUtils::PkgConfig; ExtUtils::PkgConfig->libs('lapack')} || `pkg-config lapack blas --libs` || '-L/usr/lib/atlas -llapack -lblas -latlas' ) . " -lgfortran -lquadmath"; $hash{LDLOADLIBS} .= 'oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib msvcrt.lib ../lapack/libacml.lib "C:\Program Files\Microsoft Visual Studio .NET 2003\Vc7\lib\msvcrt.lib" ' if $^O =~ /MSWin/ && $Config{cc} eq 'cl'; WriteMakefile( %hash, 'VERSION_FROM' => 'complex.pd', 'clean' => { FILES => '*~' }, ); # Add genpp rule # add other makefile additions as required (see also ExtUtils::MakeMaker) sub MY::postamble { pdlpp_postamble(@::pack); } PDL-LinearAlgebra-0.12/Complex/Makefile.PL.pkg0000755113142400244210000000157612247720255023142 0ustar chris.h.marshallDomain Users # Use this as a template for the Makefile.PL for # any external PDL module. use ExtUtils::MakeMaker; PDL::Core::Dev->import(); @pack = (["Complex.pd",Complex, PDL::LinearAlgebra::Complex]); %hash = pdlpp_stdargs_int(@::pack); # $hash{'OPTIMIZE'} = '-g'; # If you want to debug, uncomment this. $hash{LIBS}[0] .= $^O =~ /MSWin/ ? '' : '-L/usr/lib/atlas -llapack -lf77blas -lcblas -latlas -lg2c '; $hash{LDLOADLIBS} .= 'oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib msvcrt.lib ../lapack/lapack.lib' if $^O =~ /MSWin/; WriteMakefile( %hash, 'VERSION_FROM' => "complex.pd", ); # Add genpp rule # add other makefile additions as required (see also ExtUtils::MakeMaker) sub MY::postamble { pdlpp_postamble_int(@::pack); } PDL-LinearAlgebra-0.12/Config0000755113142400244210000000006312247720255020117 0ustar chris.h.marshallDomain Users%config = ( CBLAS => 0, WITHOUT_THREAD => 0 ); PDL-LinearAlgebra-0.12/GENERATED/0000755113142400244210000000000012535325333020261 5ustar chris.h.marshallDomain UsersPDL-LinearAlgebra-0.12/GENERATED/PDL/0000755113142400244210000000000012535325333020700 5ustar chris.h.marshallDomain UsersPDL-LinearAlgebra-0.12/GENERATED/PDL/LinearAlgebra/0000755113142400244210000000000012535325336023373 5ustar chris.h.marshallDomain UsersPDL-LinearAlgebra-0.12/GENERATED/PDL/LinearAlgebra/Complex.pm0000644113142400244210000013204012535325335025337 0ustar chris.h.marshallDomain Users # # GENERATED WITH PDL::PP! Don't modify! # package PDL::LinearAlgebra::Complex; @EXPORT_OK = qw( PDL::PP cgesvd PDL::PP cgesdd PDL::PP cggsvd PDL::PP cgeev PDL::PP cgeevx PDL::PP cggev PDL::PP cggevx PDL::PP cgees PDL::PP cgeesx PDL::PP cgges PDL::PP cggesx PDL::PP cheev PDL::PP cheevd PDL::PP cheevx PDL::PP cheevr PDL::PP chegv PDL::PP chegvd PDL::PP chegvx PDL::PP cgesv PDL::PP cgesvx PDL::PP csysv PDL::PP csysvx PDL::PP chesv PDL::PP chesvx PDL::PP cposv PDL::PP cposvx PDL::PP cgels PDL::PP cgelsy PDL::PP cgelss PDL::PP cgelsd PDL::PP cgglse PDL::PP cggglm PDL::PP cgetrf PDL::PP cgetf2 PDL::PP csytrf PDL::PP csytf2 PDL::PP cchetrf PDL::PP chetf2 PDL::PP cpotrf PDL::PP cpotf2 PDL::PP cgetri PDL::PP csytri PDL::PP chetri PDL::PP cpotri PDL::PP ctrtri PDL::PP ctrti2 PDL::PP cgetrs PDL::PP csytrs PDL::PP chetrs PDL::PP cpotrs PDL::PP ctrtrs PDL::PP clatrs PDL::PP cgecon PDL::PP csycon PDL::PP checon PDL::PP cpocon PDL::PP ctrcon PDL::PP cgeqp3 PDL::PP cgeqrf PDL::PP cungqr PDL::PP cunmqr PDL::PP cgelqf PDL::PP cunglq PDL::PP cunmlq PDL::PP cgeqlf PDL::PP cungql PDL::PP cunmql PDL::PP cgerqf PDL::PP cungrq PDL::PP cunmrq PDL::PP ctzrzf PDL::PP cunmrz PDL::PP cgehrd PDL::PP cunghr PDL::PP chseqr PDL::PP ctrevc PDL::PP ctgevc PDL::PP cgebal PDL::PP clange PDL::PP clansy PDL::PP clantr PDL::PP cgemm PDL::PP cmmult PDL::PP ccrossprod PDL::PP csyrk PDL::PP cdot PDL::PP cdotc PDL::PP caxpy PDL::PP cnrm2 PDL::PP casum PDL::PP cscal PDL::PP sscal PDL::PP crotg PDL::PP clacpy PDL::PP claswp PDL::PP ctricpy PDL::PP cmstack PDL::PP ccharpol ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; $PDL::LinearAlgebra::Complex::VERSION = '0.12'; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::LinearAlgebra::Complex $VERSION; use strict; use PDL::Complex; use PDL::LinearAlgebra::Real; { package # hide from CPAN PDL; my $warningFlag; BEGIN{ $warningFlag = $^W; $^W = 0; } use overload ( 'x' => sub {UNIVERSAL::isa($_[1],'PDL::Complex') ? PDL::cmmult(PDL::Complex::r2C($_[0]), $_[1]): PDL::mmult($_[0], $_[1]); }); BEGIN{ $^W = $warningFlag ; } } { package # hide from CPAN PDL::Complex; my $warningFlag; BEGIN{ $warningFlag = $^W; $^W = 0; } use overload ( 'x' => sub {UNIVERSAL::isa($_[1],'PDL::Complex') ? PDL::cmmult($_[0], $_[1]) : PDL::cmmult($_[0], PDL::Complex::r2C($_[1])); }, ); BEGIN{ $^W = $warningFlag ; } } =encoding Latin-1 =head1 NAME PDL::LinearAlgebra::Complex - PDL interface to the lapack linear algebra programming library (complex number) =head1 SYNOPSIS use PDL::Complex use PDL::LinearAlgebra::Complex; $a = r2C random (100,100); $s = r2C zeroes(100); $u = r2C zeroes(100,100); $v = r2C zeroes(100,100); $info = 0; $job = 0; cgesdd($a, $job, $info, $s , $u, $v); =head1 DESCRIPTION This module provides an interface to parts of the lapack library (complex numbers). These routines accept either float or double piddles. =head1 FUNCTIONS =cut =head2 cgesvd =for sig Signature: ([io,phys]A(2,m,n); int jobu(); int jobvt(); [o,phys]s(r); [o,phys]U(2,p,q); [o,phys]VT(2,s,t); int [o,phys]info()) =for ref Complex version of gesvd. The SVD is written A = U * SIGMA * ConjugateTranspose(V) =for bad cgesvd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgesvd = \&PDL::cgesvd; =head2 cgesdd =for sig Signature: ([io,phys]A(2,m,n); int job(); [o,phys]s(r); [o,phys]U(2,p,q); [o,phys]VT(2,s,t); int [o,phys]info()) =for ref Complex version of gesdd. The SVD is written A = U * SIGMA * ConjugateTranspose(V) =for bad cgesdd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgesdd = \&PDL::cgesdd; =head2 cggsvd =for sig Signature: ([io,phys]A(2,m,n); int jobu(); int jobv(); int jobq(); [io,phys]B(2,p,n); int [o,phys]k(); int [o,phys]l();[o,phys]alpha(n);[o,phys]beta(n); [o,phys]U(2,q,r); [o,phys]V(2,s,t); [o,phys]Q(2,u,v); int [o,phys]iwork(n); int [o,phys]info()) =for ref Complex version of ggsvd =for bad cggsvd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cggsvd = \&PDL::cggsvd; =head2 cgeev =for sig Signature: ([phys]A(2,n,n); int jobvl(); int jobvr(); [o,phys]w(2,n); [o,phys]vl(2,m,m); [o,phys]vr(2,p,p); int [o,phys]info()) =for ref Complex version of geev =for bad cgeev ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgeev = \&PDL::cgeev; =head2 cgeevx =for sig Signature: ([io,phys]A(2,n,n); int jobvl(); int jobvr(); int balance(); int sense(); [o,phys]w(2,n); [o,phys]vl(2,m,m); [o,phys]vr(2,p,p); int [o,phys]ilo(); int [o,phys]ihi(); [o,phys]scale(n); [o,phys]abnrm(); [o,phys]rconde(q); [o,phys]rcondv(r); int [o,phys]info()) =for ref Complex version of geevx =for bad cgeevx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgeevx = \&PDL::cgeevx; =head2 cggev =for sig Signature: ([phys]A(2,n,n); int jobvl();int jobvr();[phys]B(2,n,n);[o,phys]alpha(2,n);[o,phys]beta(2,n);[o,phys]VL(2,m,m);[o,phys]VR(2,p,p);int [o,phys]info()) =for ref Complex version of ggev =for bad cggev ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cggev = \&PDL::cggev; =head2 cggevx =for sig Signature: ([io,phys]A(2,n,n);int balanc();int jobvl();int jobvr();int sense();[io,phys]B(2,n,n);[o,phys]alpha(2,n);[o,phys]beta(2,n);[o,phys]VL(2,m,m);[o,phys]VR(2,p,p);int [o,phys]ilo();int [o,phys]ihi();[o,phys]lscale(n);[o,phys]rscale(n);[o,phys]abnrm();[o,phys]bbnrm();[o,phys]rconde(r);[o,phys]rcondv(s);int [o,phys]info()) =for ref Complex version of ggevx =for bad cggevx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cggevx = \&PDL::cggevx; =head2 cgees =for sig Signature: ([io,phys]A(2,n,n); int jobvs(); int sort(); [o,phys]w(2,n); [o,phys]vs(2,p,p); int [o,phys]sdim(); int [o,phys]info(); SV* select_func) =for ref Complex version of gees select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form. If sort = 0, select_func is not referenced. An complex eigenvalue w is selected if select_func(PDL::Complex(w)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func(PDL::Complex(w)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info is set to N+2. =for bad cgees ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgees = \&PDL::cgees; =head2 cgeesx =for sig Signature: ([io,phys]A(2,n,n); int jobvs(); int sort(); int sense(); [o,phys]w(2,n);[o,phys]vs(2,p,p); int [o,phys]sdim(); [o,phys]rconde();[o,phys]rcondv(); int [o,phys]info(); SV* select_func) =for ref Complex version of geesx select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form. If sort = 0, select_func is not referenced. An complex eigenvalue w is selected if select_func(PDL::Complex(w)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func(PDL::Complex(w)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info is set to N+2. =for bad cgeesx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgeesx = \&PDL::cgeesx; =head2 cgges =for sig Signature: ([io,phys]A(2,n,n); int jobvsl();int jobvsr();int sort();[io,phys]B(2,n,n);[o,phys]alpha(2,n);[o,phys]beta(2,n);[o,phys]VSL(2,m,m);[o,phys]VSR(2,p,p);int [o,phys]sdim();int [o,phys]info(); SV* select_func) =for ref Complex version of ggees select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form. If sort = 0, select_func is not referenced. An eigenvalue w = w/beta is selected if select_func(PDL::Complex(w), PDL::Complex(beta)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func(PDL::Complex(w),PDL::Complex(beta)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info is set to N+2. =for bad cgges ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgges = \&PDL::cgges; =head2 cggesx =for sig Signature: ([io,phys]A(2,n,n); int jobvsl();int jobvsr();int sort();int sense();[io,phys]B(2,n,n);[o,phys]alpha(2,n);[o,phys]beta(2,n);[o,phys]VSL(2,m,m);[o,phys]VSR(2,p,p);int [o,phys]sdim();[o,phys]rconde(q);[o,phys]rcondv(r);int [o,phys]info(); SV* select_func) =for ref Complex version of ggeesx select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form. If sort = 0, select_func is not referenced. An eigenvalue w = w/beta is selected if select_func(PDL::Complex(w), PDL::Complex(beta)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func(PDL::Complex(w),PDL::Complex(beta)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info is set to N+3. =for bad cggesx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cggesx = \&PDL::cggesx; =head2 cheev =for sig Signature: ([io,phys]A(2,n,n); int jobz(); int uplo(); [o,phys]w(n); int [o,phys]info()) =for ref Complex version of syev for Hermitian matrix =for bad cheev ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cheev = \&PDL::cheev; =head2 cheevd =for sig Signature: ([io,phys]A(2,n,n); int jobz(); int uplo(); [o,phys]w(n); int [o,phys]info()) =for ref Complex version of syevd for Hermitian matrix =for bad cheevd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cheevd = \&PDL::cheevd; =head2 cheevx =for sig Signature: ([phys]A(2,n,n); int jobz(); int range(); int uplo(); [phys]vl(); [phys]vu(); int [phys]il(); int [phys]iu(); [phys]abstol(); int [o,phys]m(); [o,phys]w(n); [o,phys]z(2,p,q);int [o,phys]ifail(r); int [o,phys]info()) =for ref Complex version of syevx for Hermitian matrix =for bad cheevx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cheevx = \&PDL::cheevx; =head2 cheevr =for sig Signature: ([phys]A(2,n,n); int jobz(); int range(); int uplo(); [phys]vl(); [phys]vu(); int [phys]il(); int [phys]iu(); [phys]abstol(); int [o,phys]m(); [o,phys]w(n); [o,phys]z(2,p,q);int [o,phys]isuppz(r); int [o,phys]info()) =for ref Complex version of syevr for Hermitian matrix =for bad cheevr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cheevr = \&PDL::cheevr; =head2 chegv =for sig Signature: ([io,phys]A(2,n,n);int [phys]itype();int jobz(); int uplo();[io,phys]B(2,n,n);[o,phys]w(n); int [o,phys]info()) =for ref Complex version of sygv for Hermitian matrix =for bad chegv ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chegv = \&PDL::chegv; =head2 chegvd =for sig Signature: ([io,phys]A(2,n,n);int [phys]itype();int jobz(); int uplo();[io,phys]B(2,n,n);[o,phys]w(n); int [o,phys]info()) =for ref Complex version of sygvd for Hermitian matrix =for bad chegvd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chegvd = \&PDL::chegvd; =head2 chegvx =for sig Signature: ([io,phys]A(2,n,n);int [phys]itype();int jobz();int range(); int uplo();[io,phys]B(2,n,n);[phys]vl();[phys]vu();int [phys]il();int [phys]iu();[phys]abstol();int [o,phys]m();[o,phys]w(n); [o,phys]Z(2,p,q);int [o,phys]ifail(r);int [o,phys]info()) =for ref Complex version of sygvx for Hermitian matrix =for bad chegvx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chegvx = \&PDL::chegvx; =head2 cgesv =for sig Signature: ([io,phys]A(2,n,n); [io,phys]B(2,n,m); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Complex version of gesv =for bad cgesv ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgesv = \&PDL::cgesv; =head2 cgesvx =for sig Signature: ([io,phys]A(2,n,n); int trans(); int fact(); [io,phys]B(2,n,m); [io,phys]af(2,n,n); int [io,phys]ipiv(n); int [io]equed(); [io,phys]r(n); [io,phys]c(n); [o,phys]X(2,n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); [o,phys]rpvgrw(); int [o,phys]info()) =for ref Complex version of gesvx. trans: Specifies the form of the system of equations: = 0: A * X = B (No transpose) = 1: A' * X = B (Transpose) = 2: A**H * X = B (Conjugate transpose) =for bad cgesvx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgesvx = \&PDL::cgesvx; =head2 csysv =for sig Signature: ([io,phys]A(2,n,n); int uplo(); [io,phys]B(2,n,m); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Complex version of sysv =for bad csysv ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *csysv = \&PDL::csysv; =head2 csysvx =for sig Signature: ([phys]A(2,n,n); int uplo(); int fact(); [phys]B(2,n,m); [io,phys]af(2,n,n); int [io,phys]ipiv(n); [o,phys]X(2,n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); int [o,phys]info()) =for ref Complex version of sysvx =for bad csysvx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *csysvx = \&PDL::csysvx; =head2 chesv =for sig Signature: ([io,phys]A(2,n,n); int uplo(); [io,phys]B(2,n,m); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Complex version of sysv for Hermitian matrix =for bad chesv ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chesv = \&PDL::chesv; =head2 chesvx =for sig Signature: ([phys]A(2,n,n); int uplo(); int fact(); [phys]B(2,n,m); [io,phys]af(2,n,n); int [io,phys]ipiv(n); [o,phys]X(2,n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); int [o,phys]info()) =for ref Complex version of sysvx for Hermitian matrix =for bad chesvx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chesvx = \&PDL::chesvx; =head2 cposv =for sig Signature: ([io,phys]A(2,n,n); int uplo(); [io,phys]B(2,n,m); int [o,phys]info()) =for ref Complex version of posv for Hermitian positive definite matrix =for bad cposv ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cposv = \&PDL::cposv; =head2 cposvx =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int fact(); [io,phys]B(2,n,m); [io,phys]af(2,n,n); int [io]equed(); [io,phys]s(n); [o,phys]X(2,n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); int [o,phys]info()) =for ref Complex version of posvx for Hermitian positive definite matrix =for bad cposvx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cposvx = \&PDL::cposvx; =head2 cgels =for sig Signature: ([io,phys]A(2,m,n); int trans(); [io,phys]B(2,p,q);int [o,phys]info()) =for ref Solves overdetermined or underdetermined complex linear systems involving an M-by-N matrix A, or its conjugate-transpose. Complex version of gels. trans: = 0: the linear system involves A; = 1: the linear system involves A**H. =for bad cgels ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgels = \&PDL::cgels; =head2 cgelsy =for sig Signature: ([io,phys]A(2,m,n); [io,phys]B(2,p,q); [phys]rcond(); int [io,phys]jpvt(n); int [o,phys]rank();int [o,phys]info()) =for ref Complex version of gelsy =for bad cgelsy ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgelsy = \&PDL::cgelsy; =head2 cgelss =for sig Signature: ([io,phys]A(2,m,n); [io,phys]B(2,p,q); [phys]rcond(); [o,phys]s(r); int [o,phys]rank();int [o,phys]info()) =for ref Complex version of gelss =for bad cgelss ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgelss = \&PDL::cgelss; =head2 cgelsd =for sig Signature: ([io,phys]A(2,m,n); [io,phys]B(2,p,q); [phys]rcond(); [o,phys]s(r); int [o,phys]rank();int [o,phys]info()) =for ref Complex version of gelsd =for bad cgelsd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgelsd = \&PDL::cgelsd; =head2 cgglse =for sig Signature: ([phys]A(2,m,n); [phys]B(2,p,n);[io,phys]c(2,m);[phys]d(2,p);[o,phys]x(2,n);int [o,phys]info()) =for ref Complex version of gglse =for bad cgglse ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgglse = \&PDL::cgglse; =head2 cggglm =for sig Signature: ([phys]A(2,n,m); [phys]B(2,n,p);[phys]d(2,n);[o,phys]x(2,m);[o,phys]y(2,p);int [o,phys]info()) =for ref Complex version of ggglm =for bad cggglm ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cggglm = \&PDL::cggglm; =head2 cgetrf =for sig Signature: ([io,phys]A(2,m,n); int [o,phys]ipiv(p); int [o,phys]info()) =for ref Complex version of getrf =for bad cgetrf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgetrf = \&PDL::cgetrf; =head2 cgetf2 =for sig Signature: ([io,phys]A(2,m,n); int [o,phys]ipiv(p); int [o,phys]info()) =for ref Complex version of getf2 =for bad cgetf2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgetf2 = \&PDL::cgetf2; =head2 csytrf =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Complex version of sytrf =for bad csytrf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *csytrf = \&PDL::csytrf; =head2 csytf2 =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Complex version of sytf2 =for bad csytf2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *csytf2 = \&PDL::csytf2; =head2 cchetrf =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Complex version of sytrf for Hermitian matrix =for bad cchetrf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cchetrf = \&PDL::cchetrf; =head2 chetf2 =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Complex version of sytf2 for Hermitian matrix =for bad chetf2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chetf2 = \&PDL::chetf2; =head2 cpotrf =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int [o,phys]info()) =for ref Complex version of potrf for Hermitian positive definite matrix =for bad cpotrf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cpotrf = \&PDL::cpotrf; =head2 cpotf2 =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int [o,phys]info()) =for ref Complex version of potf2 for Hermitian positive definite matrix =for bad cpotf2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cpotf2 = \&PDL::cpotf2; =head2 cgetri =for sig Signature: ([io,phys]A(2,n,n); int [phys]ipiv(n); int [o,phys]info()) =for ref Complex version of getri =for bad cgetri ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgetri = \&PDL::cgetri; =head2 csytri =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int [phys]ipiv(n); int [o,phys]info()) =for ref Complex version of sytri =for bad csytri ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *csytri = \&PDL::csytri; =head2 chetri =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int [phys]ipiv(n); int [o,phys]info()) =for ref Complex version of sytri for Hermitian matrix =for bad chetri ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chetri = \&PDL::chetri; =head2 cpotri =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int [o,phys]info()) =for ref Complex version of potri =for bad cpotri ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cpotri = \&PDL::cpotri; =head2 ctrtri =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int diag(); int [o,phys]info()) =for ref Complex version of trtri =for bad ctrtri ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ctrtri = \&PDL::ctrtri; =head2 ctrti2 =for sig Signature: ([io,phys]A(2,n,n); int uplo(); int diag(); int [o,phys]info()) =for ref Complex version of trti2 =for bad ctrti2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ctrti2 = \&PDL::ctrti2; =head2 cgetrs =for sig Signature: ([phys]A(2,n,n); int trans(); [io,phys]B(2,n,m); int [phys]ipiv(n); int [o,phys]info()) =for ref Complex version of getrs Arguments ========= trans: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; =for bad cgetrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgetrs = \&PDL::cgetrs; =head2 csytrs =for sig Signature: ([phys]A(2,n,n); int uplo();[io,phys]B(2,n,m); int [phys]ipiv(n); int [o,phys]info()) =for ref Complex version of sytrs =for bad csytrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *csytrs = \&PDL::csytrs; =head2 chetrs =for sig Signature: ([phys]A(2,n,n); int uplo();[io,phys]B(2,n,m); int [phys]ipiv(n); int [o,phys]info()) =for ref Complex version of sytrs for Hermitian matrix =for bad chetrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chetrs = \&PDL::chetrs; =head2 cpotrs =for sig Signature: ([phys]A(2,n,n); int uplo(); [io,phys]B(2,n,m); int [o,phys]info()) =for ref Complex version of potrs for Hermitian positive definite matrix =for bad cpotrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cpotrs = \&PDL::cpotrs; =head2 ctrtrs =for sig Signature: ([phys]A(2,n,n); int uplo(); int trans(); int diag();[io,phys]B(2,n,m); int [o,phys]info()) =for ref Complex version of trtrs Arguments ========= trans: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; =for bad ctrtrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ctrtrs = \&PDL::ctrtrs; =head2 clatrs =for sig Signature: ([phys]A(2,n,n); int uplo(); int trans(); int diag(); int normin();[io,phys]x(2,n); [o,phys]scale();[io,phys]cnorm(n);int [o,phys]info()) =for ref Complex version of latrs Arguments ========= trans: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; =for bad clatrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *clatrs = \&PDL::clatrs; =head2 cgecon =for sig Signature: ([phys]A(2,n,n); int norm(); [phys]anorm(); [o,phys]rcond();int [o,phys]info()) =for ref Complex version of gecon =for bad cgecon ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgecon = \&PDL::cgecon; =head2 csycon =for sig Signature: ([phys]A(2,n,n); int uplo(); int ipiv(n); [phys]anorm(); [o,phys]rcond();int [o,phys]info()) =for ref Complex version of sycon =for bad csycon ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *csycon = \&PDL::csycon; =head2 checon =for sig Signature: ([phys]A(2,n,n); int uplo(); int ipiv(n); [phys]anorm(); [o,phys]rcond();int [o,phys]info()) =for ref Complex version of sycon for Hermitian matrix =for bad checon ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *checon = \&PDL::checon; =head2 cpocon =for sig Signature: ([phys]A(2,n,n); int uplo(); [phys]anorm(); [o,phys]rcond();int [o,phys]info()) =for ref Complex version of pocon for Hermitian positive definite matrix =for bad cpocon ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cpocon = \&PDL::cpocon; =head2 ctrcon =for sig Signature: ([phys]A(2,n,n); int norm();int uplo();int diag(); [o,phys]rcond();int [o,phys]info()) =for ref Complex version of trcon =for bad ctrcon ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ctrcon = \&PDL::ctrcon; =head2 cgeqp3 =for sig Signature: ([io,phys]A(2,m,n); int [io,phys]jpvt(n); [o,phys]tau(2,k); int [o,phys]info()) =for ref Complex version of geqp3 =for bad cgeqp3 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgeqp3 = \&PDL::cgeqp3; =head2 cgeqrf =for sig Signature: ([io,phys]A(2,m,n); [o,phys]tau(2,k); int [o,phys]info()) =for ref Complex version of geqrf =for bad cgeqrf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgeqrf = \&PDL::cgeqrf; =head2 cungqr =for sig Signature: ([io,phys]A(2,m,n); [phys]tau(2,k); int [o,phys]info()) =for ref Complex version of orgqr =for bad cungqr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cungqr = \&PDL::cungqr; =head2 cunmqr =for sig Signature: ([phys]A(2,p,k); int side(); int trans(); [phys]tau(2,k); [io,phys]C(2,m,n);int [o,phys]info()) =for ref Complex version of ormqr. Here trans = 1 means conjugate transpose. =for bad cunmqr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cunmqr = \&PDL::cunmqr; =head2 cgelqf =for sig Signature: ([io,phys]A(2,m,n); [o,phys]tau(2,k); int [o,phys]info()) =for ref Complex version of gelqf =for bad cgelqf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgelqf = \&PDL::cgelqf; =head2 cunglq =for sig Signature: ([io,phys]A(2,m,n); [phys]tau(2,k); int [o,phys]info()) =for ref Complex version of orglq =for bad cunglq ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cunglq = \&PDL::cunglq; =head2 cunmlq =for sig Signature: ([phys]A(2,k,p); int side(); int trans(); [phys]tau(2,k); [io,phys]C(2,m,n);int [o,phys]info()) =for ref Complex version of ormlq. Here trans = 1 means conjugate transpose. =for bad cunmlq ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cunmlq = \&PDL::cunmlq; =head2 cgeqlf =for sig Signature: ([io,phys]A(2,m,n); [o,phys]tau(2,k); int [o,phys]info()) =for ref Complex version of geqlf =for bad cgeqlf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgeqlf = \&PDL::cgeqlf; =head2 cungql =for sig Signature: ([io,phys]A(2,m,n); [phys]tau(2,k); int [o,phys]info()) =for ref Complex version of orgql. =for bad cungql ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cungql = \&PDL::cungql; =head2 cunmql =for sig Signature: ([phys]A(2,p,k); int side(); int trans(); [phys]tau(2,k); [io,phys]C(2,m,n);int [o,phys]info()) =for ref Complex version of ormql. Here trans = 1 means conjugate transpose. =for bad cunmql ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cunmql = \&PDL::cunmql; =head2 cgerqf =for sig Signature: ([io,phys]A(2,m,n); [o,phys]tau(2,k); int [o,phys]info()) =for ref Complex version of gerqf =for bad cgerqf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgerqf = \&PDL::cgerqf; =head2 cungrq =for sig Signature: ([io,phys]A(2,m,n); [phys]tau(2,k); int [o,phys]info()) =for ref Complex version of orgrq. =for bad cungrq ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cungrq = \&PDL::cungrq; =head2 cunmrq =for sig Signature: ([phys]A(2,k,p); int side(); int trans(); [phys]tau(2,k); [io,phys]C(2,m,n);int [o,phys]info()) =for ref Complex version of ormrq. Here trans = 1 means conjugate transpose. =for bad cunmrq ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cunmrq = \&PDL::cunmrq; =head2 ctzrzf =for sig Signature: ([io,phys]A(2,m,n); [o,phys]tau(2,k); int [o,phys]info()) =for ref Complex version of tzrzf =for bad ctzrzf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ctzrzf = \&PDL::ctzrzf; =head2 cunmrz =for sig Signature: ([phys]A(2,k,p); int side(); int trans(); [phys]tau(2,k); [io,phys]C(2,m,n);int [o,phys]info()) =for ref Complex version of ormrz. Here trans = 1 means conjugate transpose. =for bad cunmrz ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cunmrz = \&PDL::cunmrz; =head2 cgehrd =for sig Signature: ([io,phys]A(2,n,n); int [phys]ilo();int [phys]ihi();[o,phys]tau(2,k); int [o,phys]info()) =for ref Complex version of gehrd =for bad cgehrd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgehrd = \&PDL::cgehrd; =head2 cunghr =for sig Signature: ([io,phys]A(2,n,n); int [phys]ilo();int [phys]ihi();[phys]tau(2,k); int [o,phys]info()) =for ref Complex version of orghr =for bad cunghr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cunghr = \&PDL::cunghr; =head2 chseqr =for sig Signature: ([io,phys]H(2,n,n); int job();int compz();int [phys]ilo();int [phys]ihi();[o,phys]w(2,n); [o,phys]Z(2,m,m); int [o,phys]info()) =for ref Complex version of hseqr =for bad chseqr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chseqr = \&PDL::chseqr; =head2 ctrevc =for sig Signature: ([io,phys]T(2,n,n); int side();int howmny();int [phys]select(q);[io,phys]VL(2,m,r); [io,phys]VR(2,p,s);int [o,phys]m(); int [o,phys]info()) =for ref Complex version of trevc =for bad ctrevc ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ctrevc = \&PDL::ctrevc; =head2 ctgevc =for sig Signature: ([io,phys]A(2,n,n); int side();int howmny(); [io,phys]B(2,n,n);int [phys]select(q);[io,phys]VL(2,m,r); [io,phys]VR(2,p,s);int [o,phys]m(); int [o,phys]info()) =for ref Complex version of tgevc =for bad ctgevc ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ctgevc = \&PDL::ctgevc; =head2 cgebal =for sig Signature: ([io,phys]A(2,n,n); int job(); int [o,phys]ilo();int [o,phys]ihi();[o,phys]scale(n); int [o,phys]info()) =for ref Complex version of gebal =for bad cgebal ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgebal = \&PDL::cgebal; =head2 clange =for sig Signature: ([phys]A(2,n,m); int norm(); [o]b()) =for ref Complex version of lange =for bad clange ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *clange = \&PDL::clange; =head2 clansy =for sig Signature: ([phys]A(2, n,n); int uplo(); int norm(); [o]b()) =for ref Complex version of lansy =for bad clansy ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *clansy = \&PDL::clansy; =head2 clantr =for sig Signature: ([phys]A(2,m,n);int uplo();int norm();int diag();[o]b()) =for ref Complex version of lantr =for bad clantr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *clantr = \&PDL::clantr; =head2 cgemm =for sig Signature: ([phys]A(2,m,n); int transa(); int transb(); [phys]B(2,p,q);[phys]alpha(2); [phys]beta(2); [io,phys]C(2,r,s)) =for ref Complex version of gemm. Arguments ========= transa: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; transb: = 0: No transpose; = 1: Transpose; = 2: Conjugate transpose; =for bad cgemm ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgemm = \&PDL::cgemm; =head2 cmmult =for sig Signature: ([phys]A(2,m,n); [phys]B(2,p,m); [o,phys]C(2,p,n)) =for ref Complex version of mmult =for bad cmmult ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cmmult = \&PDL::cmmult; =head2 ccrossprod =for sig Signature: ([phys]A(2,n,m); [phys]B(2,p,m); [o,phys]C(2,p,n)) =for ref Complex version of crossprod =for bad ccrossprod ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ccrossprod = \&PDL::ccrossprod; =head2 csyrk =for sig Signature: ([phys]A(2,m,n); int uplo(); int trans(); [phys]alpha(2); [phys]beta(2); [io,phys]C(2,p,p)) =for ref Complex version of syrk =for bad csyrk ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *csyrk = \&PDL::csyrk; =head2 cdot =for sig Signature: ([phys]a(2,n);int [phys]inca();[phys]b(2,n);int [phys]incb();[o,phys]c(2)) =for ref Complex version of dot =for bad cdot ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cdot = \&PDL::cdot; =head2 cdotc =for sig Signature: ([phys]a(2,n);int [phys]inca();[phys]b(2,n);int [phys]incb();[o,phys]c(2)) =for ref Forms the dot product of two vectors, conjugating the first vector. =for bad cdotc ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cdotc = \&PDL::cdotc; =head2 caxpy =for sig Signature: ([phys]a(2,n);int [phys]inca();[phys] alpha(2);[io,phys]b(2,n);int [phys]incb()) =for ref Complex version of axpy =for bad caxpy ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *caxpy = \&PDL::caxpy; =head2 cnrm2 =for sig Signature: ([phys]a(2,n);int [phys]inca();[o,phys]b()) =for ref Complex version of nrm2 =for bad cnrm2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cnrm2 = \&PDL::cnrm2; =head2 casum =for sig Signature: ([phys]a(2,n);int [phys]inca();[o,phys]b()) =for ref Complex version of asum =for bad casum ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *casum = \&PDL::casum; =head2 cscal =for sig Signature: ([io,phys]a(2,n);int [phys]inca();[phys]scale(2)) =for ref Complex version of scal =for bad cscal ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cscal = \&PDL::cscal; =head2 sscal =for sig Signature: ([io,phys]a(2,n);int [phys]inca();[phys]scale()) =for ref Scales a complex vector by a real constant. =for bad sscal ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sscal = \&PDL::sscal; =head2 crotg =for sig Signature: ([io,phys]a(2);[phys]b(2);[o,phys]c(); [o,phys]s(2)) =for ref Complex version of rotg =for bad crotg ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *crotg = \&PDL::crotg; =head2 clacpy =for sig Signature: ([phys]A(2,m,n); int uplo(); [o,phys]B(2,p,n)) =for ref Complex version of lacpy =for bad clacpy ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *clacpy = \&PDL::clacpy; =head2 claswp =for sig Signature: ([io,phys]A(2,m,n); int [phys]k1(); int [phys]k2(); int [phys]ipiv(p);int [phys]inc()) =for ref Complex version of laswp =for bad claswp ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *claswp = \&PDL::claswp; =head2 ctricpy =for sig Signature: (A(c=2,m,n);int uplo();[o] C(c=2,m,n)) =for ref Copy triangular part to another matrix. If uplo == 0 copy upper triangular part. =for bad ctricpy does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ctricpy = \&PDL::ctricpy; =head2 cmstack =for sig Signature: (x(c,n,m);y(c,n,p);[o]out(c,n,q)) =for ref Combine two 3D piddles into a single piddle. This routine does backward and forward dataflow automatically. =for bad cmstack does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cmstack = \&PDL::cmstack; =head2 ccharpol =for sig Signature: ([phys]A(c=2,n,n);[phys,o]Y(c=2,n,n);[phys,o]out(c=2,p)) =for ref Complex version of charpol =for bad ccharpol does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ccharpol = \&PDL::ccharpol; ; =head1 AUTHOR Copyright (C) Grégory Vanuxem 2005-2007. This library is free software; you can redistribute it and/or modify it under the terms of the artistic license as specified in the Artistic file. =cut # Exit with OK status 1; PDL-LinearAlgebra-0.12/GENERATED/PDL/LinearAlgebra/Real.pm0000644113142400244210000074650712535325336024637 0ustar chris.h.marshallDomain Users # # GENERATED WITH PDL::PP! Don't modify! # package PDL::LinearAlgebra::Real; @EXPORT_OK = qw( PDL::PP gesvd PDL::PP gesdd PDL::PP ggsvd PDL::PP geev PDL::PP geevx PDL::PP ggev PDL::PP ggevx PDL::PP gees PDL::PP geesx PDL::PP gges PDL::PP ggesx PDL::PP syev PDL::PP syevd PDL::PP syevx PDL::PP syevr PDL::PP sygv PDL::PP sygvd PDL::PP sygvx PDL::PP gesv PDL::PP gesvx PDL::PP sysv PDL::PP sysvx PDL::PP posv PDL::PP posvx PDL::PP gels PDL::PP gelsy PDL::PP gelss PDL::PP gelsd PDL::PP gglse PDL::PP ggglm PDL::PP getrf PDL::PP getf2 PDL::PP sytrf PDL::PP sytf2 PDL::PP potrf PDL::PP potf2 PDL::PP getri PDL::PP sytri PDL::PP potri PDL::PP trtri PDL::PP trti2 PDL::PP getrs PDL::PP sytrs PDL::PP potrs PDL::PP trtrs PDL::PP latrs PDL::PP gecon PDL::PP sycon PDL::PP pocon PDL::PP trcon PDL::PP geqp3 PDL::PP geqrf PDL::PP orgqr PDL::PP ormqr PDL::PP gelqf PDL::PP orglq PDL::PP ormlq PDL::PP geqlf PDL::PP orgql PDL::PP ormql PDL::PP gerqf PDL::PP orgrq PDL::PP ormrq PDL::PP tzrzf PDL::PP ormrz PDL::PP gehrd PDL::PP orghr PDL::PP hseqr PDL::PP trevc PDL::PP tgevc PDL::PP gebal PDL::PP gebak PDL::PP lange PDL::PP lansy PDL::PP lantr PDL::PP gemm PDL::PP mmult PDL::PP crossprod PDL::PP syrk PDL::PP dot PDL::PP axpy PDL::PP nrm2 PDL::PP asum PDL::PP scal PDL::PP rot PDL::PP rotg PDL::PP lasrt PDL::PP lacpy PDL::PP laswp PDL::PP lamch PDL::PP labad PDL::PP tricpy PDL::PP cplx_eigen PDL::PP augment PDL::PP mstack PDL::PP charpol ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; $PDL::LinearAlgebra::Real::VERSION = '0.12'; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::LinearAlgebra::Real $VERSION; use strict; { package # hide from CPAN PDL; my $warningFlag; BEGIN{ $warningFlag = $^W; $^W = 0; } use overload ( 'x' => sub {PDL::mmult($_[0], $_[1])}, ); BEGIN{ $^W = $warningFlag;} } =encoding Latin-1 =head1 NAME PDL::LinearAlgebra::Real - PDL interface to the real lapack linear algebra programming library =head1 SYNOPSIS use PDL::LinearAlgebra::Real; $a = random (100,100); $s = zeroes(100); $u = zeroes(100,100); $v = zeroes(100,100); $info = 0; $job = 0; gesdd($a, $job, $info, $s , $u, $v); Blas vector routine use increment. =head1 DESCRIPTION This module provides an interface to parts of the real lapack library. These routines accept either float or double piddles. =head1 FUNCTIONS =cut =head2 gesvd =for sig Signature: ([io,phys]A(m,n); int jobu(); int jobvt(); [o,phys]s(r); [o,phys]U(p,q); [o,phys]VT(s,t); int [o,phys]info()) =for ref Computes the singular value decomposition (SVD) of a real M-by-N matrix A. The SVD is written A = U * SIGMA * V' where SIGMA is an M-by-N matrix which is zero except for its min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA are the singular values of A; they are real and non-negative, and are returned in descending order. The first min(m,n) columns of U and V are the left and right singular vectors of A. Note that the routine returns VT = V', not V. jobu: Specifies options for computing all or part of the matrix U: = 0: no columns of U (no left singular vectors) are computed. = 1: all M columns of U are returned in array U: = 2: the first min(m,n) columns of U (the left singular vectors) are returned in the array U; = 3: the first min(m,n) columns of U (the left singular vectors) are overwritten on the array A; jobvt: Specifies options for computing all or part of the matrix V': = 0: no rows of V' (no right singular vectors) are computed. = 1: all N rows of V' are returned in the array VT; = 2: the first min(m,n) rows of V' (the right singular vectors) are returned in the array VT; = 3: the first min(m,n) rows of V' (the right singular vectors) are overwritten on the array A; jobvt and jobu cannot both be 3. A: On entry, the M-by-N matrix A. On exit, if jobu = 3, A is overwritten with the first min(m,n) columns of U (the left singular vectors, stored columnwise); if jobvt = 3, A is overwritten with the first min(m,n) rows of V' (the right singular vectors, stored rowwise); if jobu != 3 and jobvt != 3, the contents of A are destroyed. s: The singular values of A, sorted so that s(i) >= s(i+1). U: If jobu = 1, U contains the M-by-M orthogonal matrix U; if jobu = 3, U contains the first min(m,n) columns of U (the left singular vectors, stored columnwise); if jobu = 0 or 3, U is not referenced. Min size = [1,1]. VT: If jobvt = 1, VT contains the N-by-N orthogonal matrix V'; if jobvt = 2, VT contains the first min(m,n) rows of V' (the right singular vectors, stored rowwise); if jobvt = 0 or 3, VT is not referenced. Min size = [1,1]. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. > 0: if bdsqr did not converge, info specifies how many superdiagonals of an intermediate bidiagonal form B did not converge to zero. =for example $a = random (float, 100,100); $s = zeroes(float, 100); $u = zeroes(float, 100,100); $vt = zeroes(float, 100,100); $info = pdl(long, 0); gesvd($a, 2, 2, $s , $u, $vt, $info); =for bad gesvd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gesvd = \&PDL::gesvd; =head2 gesdd =for sig Signature: ([io,phys]A(m,n); int job(); [o,phys]s(r); [o,phys]U(p,q); [o,phys]VT(s,t); int [o,phys]info()) =for ref Computes the singular value decomposition (SVD) of a real M-by-N matrix A. This routine use the Coppen's divide and conquer algorithm. It is much faster than the simple driver for large matrices, but uses more workspace. job: Specifies options for computing all or part of matrix: = 0: no columns of U or rows of V' are computed; = 1: all M columns of U and all N rows of V' are returned in the arrays U and VT; = 2: the first min(M,N) columns of U and the first min(M,N) rows of V' are returned in the arrays U and VT; = 3: If M >= N, the first N columns of U are overwritten on the array A and all rows of V' are returned in the array VT; otherwise, all columns of U are returned in the array U and the first M rows of V' are overwritten on the array A. A: On entry, the M-by-N matrix A. On exit, if job = 3, A is overwritten with the first N columns of U (the left singular vectors, stored columnwise) if M >= N; A is overwritten with the first M rows of V' (the right singular vectors, stored rowwise) otherwise. if job != 3, the contents of A are destroyed. s: The singular values of A, sorted so that s(i) >= s(i+1). U: If job = 1 or job = 3 and M < N, U contains the M-by-M orthogonal matrix U; if job = 2, U contains the first min(M,N) columns of U (the left singular vectors, stored columnwise); if job = 3 and M >= N, or job = 0, U is not referenced. Min size = [1,1]. VT: If job = 1 or job = 3 and M >= N, VT contains the N-by-N orthogonal matrix V'; if job = 2, VT contains the first min(M,N) rows of V' (the right singular vectors, stored rowwise); if job = 3 and M < N, or job = 0, VT is not referenced. Min size = [1,1]. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. > 0: bdsdc did not converge, updating process failed. =for example $lines = 50; $columns = 100; $a = random (float, $lines, $columns); $min = $lines < $columns ? $lines : $columns; $s = zeroes(float, $min); $u = zeroes(float, $lines, $lines); $vt = zeroes(float, $columns, $columns); $info = long (0); gesdd($a, 1, $s , $u, $vt, $info); =for bad gesdd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gesdd = \&PDL::gesdd; =head2 ggsvd =for sig Signature: ([io,phys]A(m,n); int jobu(); int jobv(); int jobq(); [io,phys]B(p,n); int [o,phys]k(); int [o,phys]l();[o,phys]alpha(n);[o,phys]beta(n); [o,phys]U(q,r); [o,phys]V(s,t); [o,phys]Q(u,v); int [o,phys]iwork(n); int [o,phys]info()) =for ref Computes the generalized singular value decomposition (GSVD) of an M-by-N real matrix A and P-by-N real matrix B: U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ) where U, V and Q are orthogonal matrices, and Z' is the transpose of Z. Let K+L = the effective numerical rank of the matrix (A',B')', then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the following structures, respectively: If M-K-L >= 0, K L D1 = K ( I 0 ) L ( 0 C ) M-K-L ( 0 0 ) K L D2 = L ( 0 S ) P-L ( 0 0 ) N-K-L K L ( 0 R ) = K ( 0 R11 R12 ) L ( 0 0 R22 ) where C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), S = diag( BETA(K+1), ... , BETA(K+L) ), C**2 + S**2 = I. R is stored in A(1:K+L,N-K-L+1:N) on exit. If M-K-L < 0, K M-K K+L-M D1 = K ( I 0 0 ) M-K ( 0 C 0 ) K M-K K+L-M D2 = M-K ( 0 S 0 ) K+L-M ( 0 0 I ) P-L ( 0 0 0 ) N-K-L K M-K K+L-M ( 0 R ) = K ( 0 R11 R12 R13 ) M-K ( 0 0 R22 R23 ) K+L-M ( 0 0 0 R33 ) where C = diag( ALPHA(K+1), ... , ALPHA(M) ), S = diag( BETA(K+1), ... , BETA(M) ), C**2 + S**2 = I. (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored ( 0 R22 R23 ) in B(M-K+1:L,N+M-K-L+1:N) on exit. The routine computes C, S, R, and optionally the orthogonal transformation matrices U, V and Q. In particular, if B is an N-by-N nonsingular matrix, then the GSVD of A and B implicitly gives the SVD of A*inv(B): A*inv(B) = U*(D1*inv(D2))*V'. If ( A',B')' has orthonormal columns, then the GSVD of A and B is also equal to the CS decomposition of A and B. Furthermore, the GSVD can be used to derive the solution of the eigenvalue problem: A'*A x = lambda* B'*B x. In some literature, the GSVD of A and B is presented in the form U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 ) where U and V are orthogonal and X is nonsingular, D1 and D2 are "diagonal". The former GSVD form can be converted to the latter form by taking the nonsingular matrix X as X = Q*( I 0 ) ( 0 inv(R) ). Arguments ========= jobu: = 0: U is not computed. = 1: Orthogonal matrix U is computed; jobv: = 0: V is not computed. = 1: Orthogonal matrix V is computed; jobq: = 0: Q is not computed. = 1: Orthogonal matrix Q is computed; k: l: On exit, k and l specify the dimension of the subblocks described in the Purpose section. k + l = effective numerical rank of (A',B')'. A: On entry, the M-by-N matrix A. On exit, A contains the triangular matrix R, or part of R. B: On entry, the P-by-N matrix B. On exit, B contains the triangular matrix R if M-k-l < 0. alpha: beta: On exit, alpha and beta contain the generalized singular value pairs of A and B; alpha(1:k) = 1, beta(1:k) = 0, and if M-k-l >= 0, alpha(k+1:k+l) = C, beta(k+1:k+l) = S, or if M-k-l < 0, alpha(k+1:M)=C, alpha(M+1:k+l)=0 beta(k+1:M) =S, beta(M+1:k+l) =1 and alpha(k+l+1:N) = 0 beta(k+l+1:N) = 0 U: If jobu = 1, U contains the M-by-M orthogonal matrix U. If jobu = 0, U is not referenced. Need a minimum array of (1,1) if jobu = 0; V: If jobv = 1, V contains the P-by-P orthogonal matrix V. If jobv = 0, V is not referenced. Need a minimum array of (1,1) if jobv = 0; Q: If jobq = 1, Q contains the N-by-N orthogonal matrix Q. If jobq = 0, Q is not referenced. Need a minimum array of (1,1) if jobq = 0; iwork: On exit, iwork stores the sorting information. More precisely, the following loop will sort alpha for I = k+1, min(M,k+l) swap alpha(I) and alpha(iwork(I)) endfor such that alpha(1) >= alpha(2) >= ... >= alpha(N). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: if info = 1, the Jacobi-type procedure failed to converge. For further details, see subroutine tgsja. =for example $k = null; $l = null; $A = random(5,6); $B = random(7,6); $alpha = zeroes(6); $beta = zeroes(6); $U = zeroes(5,5); $V = zeroes(7,7); $Q = zeroes(6,6); $iwork = zeroes(long, 6); $info = null; ggsvd($A,1,1,1,$B,$k,$l,$alpha, $beta,$U, $V, $Q, $iwork,$info); =for bad ggsvd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ggsvd = \&PDL::ggsvd; =head2 geev =for sig Signature: ([phys]A(n,n); int jobvl(); int jobvr(); [o,phys]wr(n); [o,phys]wi(n); [o,phys]vl(m,m); [o,phys]vr(p,p); int [o,phys]info()) =for ref Computes for an N-by-N real nonsymmetric matrix A, the eigenvalues and, optionally, the left and/or right eigenvectors. The right eigenvector v(j) of A satisfies: A * v(j) = lambda(j) * v(j) where lambda(j) is its eigenvalue. The left eigenvector u(j) of A satisfies: u(j)**H * A = lambda(j) * u(j)**H where u(j)**H denotes the conjugate transpose of u(j). The computed eigenvectors are normalized to have Euclidean norm equal to 1 and largest component real. Arguments ========= jobvl: = 0: left eigenvectors of A are not computed; = 1: left eigenvectors of A are computed. jobvr: = 0: right eigenvectors of A are not computed; = 1: right eigenvectors of A are computed. A: A is overwritten. wr: wi: wr and wi contain the real and imaginary parts, respectively, of the computed eigenvalues. Complex conjugate pairs of eigenvalues appear consecutively with the eigenvalue having the positive imaginary part first. vl: If jobvl = 1, the left eigenvectors u(j) are stored one after another in the columns of vl, in the same order as their eigenvalues else vl is not referenced. If the j-th eigenvalue is real, then u(j) = vl(:,j), the j-th column of vl. If the j-th and (j+1)-st eigenvalues form a complex conjugate pair, then u(j) = vl(:,j) + i*vl(:,j+1) and u(j+1) = vl(:,j) - i*vl(:,j+1). Min size = [1]. vr: If jobvr = 1, the right eigenvectors v(j) are stored one after another in the columns of vr, in the same order as their eigenvalues else vr is not referenced. If the j-th eigenvalue is real, then v(j) = vr(:,j), the j-th column of vr. If the j-th and (j+1)-st eigenvalues form a complex conjugate pair, then v(j) = vr(:,j) + i*vr(:,j+1) and v(j+1) = vr(:,j) - i*vr(:,j+1). Min size = [1]. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: if info = i, the QR algorithm failed to compute all the eigenvalues, and no eigenvectors have been computed; elements i+1:N of wr and wi contain eigenvalues which have converged. =for example $a = random (5, 5); $wr = zeroes(5); $wi = zeroes($wr); $vl = zeroes($a); $vr = zeroes($a); $info = null; geev($a, 1, 1, $wr, $wi, $vl, $vr, $info); =for bad geev ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *geev = \&PDL::geev; =head2 geevx =for sig Signature: ([io,phys]A(n,n); int jobvl(); int jobvr(); int balance(); int sense(); [o,phys]wr(n); [o,phys]wi(n); [o,phys]vl(m,m); [o,phys]vr(p,p); int [o,phys]ilo(); int [o,phys]ihi(); [o,phys]scale(n); [o,phys]abnrm(); [o,phys]rconde(q); [o,phys]rcondv(r); int [o,phys]info()) =for ref Computes for an N-by-N real nonsymmetric matrix A, the eigenvalues and, optionally, the left and/or right eigenvectors. Optionally also, it computes a balancing transformation to improve the conditioning of the eigenvalues and eigenvectors (ilo, ihi, scale, and abnrm), reciprocal condition numbers for the eigenvalues (rconde), and reciprocal condition numbers for the right eigenvectors (rcondv). The right eigenvector v(j) of A satisfies: A * v(j) = lambda(j) * v(j) where lambda(j) is its eigenvalue. The left eigenvector u(j) of A satisfies: u(j)**H * A = lambda(j) * u(j)**H where u(j)**H denotes the conjugate transpose of u(j). The computed eigenvectors are normalized to have Euclidean norm equal to 1 and largest component real. Balancing a matrix means permuting the rows and columns to make it more nearly upper triangular, and applying a diagonal similarity transformation D * A * D**(-1), where D is a diagonal matrix, to make its rows and columns closer in norm and the condition numbers of its eigenvalues and eigenvectors smaller. The computed reciprocal condition numbers correspond to the balanced matrix. Permuting rows and columns will not change the condition numbers (in exact arithmetic) but diagonal scaling will. For further explanation of balancing, see section 4.10.2 of the LAPACK Users' Guide. Arguments ========= balance: Indicates how the input matrix should be diagonally scaled and/or permuted to improve the conditioning of its eigenvalues. = 0: Do not diagonally scale or permute; = 1: Perform permutations to make the matrix more nearly upper triangular. Do not diagonally scale; = 2: Diagonally scale the matrix, i.e. replace A by D*A*D**(-1), where D is a diagonal matrix chosen to make the rows and columns of A more equal in norm. Do not permute; = 3: Both diagonally scale and permute A. Computed reciprocal condition numbers will be for the matrix after balancing and/or permuting. Permuting does not change condition numbers (in exact arithmetic), but balancing does. jobvl: = 0: left eigenvectors of A are not computed; = 1: left eigenvectors of A are computed. If sense = 1 or 3, jobvl must = 1. jobvr; = 0: right eigenvectors of A are not computed; = 1: right eigenvectors of A are computed. If sense = 1 or 3, jobvr must = 1. sense: Determines which reciprocal condition numbers are computed. = 0: None are computed; = 1: Computed for eigenvalues only; = 2: Computed for right eigenvectors only; = 3: Computed for eigenvalues and right eigenvectors. If sense = 1 or 3, both left and right eigenvectors must also be computed (jobvl = 1 and jobvr = 1). A: The N-by-N matrix. It is overwritten. If jobvl = 1 or jobvr = 1, A contains the real Schur form of the balanced version of the input matrix A. wr wi: wr and wi contain the real and imaginary parts, respectively, of the computed eigenvalues. Complex conjugate pairs of eigenvalues will appear consecutively with the eigenvalue having the positive imaginary part first. vl: If jobvl = 1, the left eigenvectors u(j) are stored one after another in the columns of vl, in the same order as their eigenvalues else vl is not referenced. If the j-th eigenvalue is real, then u(j) = vl(:,j), the j-th column of vl. If the j-th and (j+1)-st eigenvalues form a complex conjugate pair, then u(j) = vl(:,j) + i*vl(:,j+1) and u(j+1) = vl(:,j) - i*vl(:,j+1). Min size = [1]. vr: If jobvr = 1, the right eigenvectors v(j) are stored one after another in the columns of vr, in the same order as their eigenvalues else vr is not referenced. If the j-th eigenvalue is real, then v(j) = vr(:,j), the j-th column of vr. If the j-th and (j+1)-st eigenvalues form a complex conjugate pair, then v(j) = vr(:,j) + i*vr(:,j+1) and v(j+1) = vr(:,j) - i*vr(:,j+1). Min size = [1]. ilo,ihi:Integer values determined when A was balanced. The balanced A(i,j) = 0 if I > J and J = 1,...,ilo-1 or I = ihi+1,...,N. scale: Details of the permutations and scaling factors applied when balancing A. If P(j) is the index of the row and column interchanged with row and column j, and D(j) is the scaling factor applied to row and column j, then scale(J) = P(J), for J = 1,...,ilo-1 = D(J), for J = ilo,...,ihi = P(J) for J = ihi+1,...,N. The order in which the interchanges are made is N to ihi+1, then 1 to ilo-1. abnrm: The one-norm of the balanced matrix (the maximum of the sum of absolute values of elements of any column). rconde: rconde(j) is the reciprocal condition number of the j-th eigenvalue. rcondv: rcondv(j) is the reciprocal condition number of the j-th right eigenvector. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: if info = i, the QR algorithm failed to compute all the eigenvalues, and no eigenvectors or condition numbers have been computed; elements 1:ilo-1 and i+1:N of wr and wi contain eigenvalues which have converged. =for example $a = random (5,5); $wr = zeroes(5); $wi = zeroes(5); $vl = zeroes(5,5); $vr = zeroes(5,5); $ilo = null; $ihi = null; $scale = zeroes(5); $abnrm = null; $rconde = zeroes(5); $rcondv = zeroes(5); $info = null; geevx($a, 1,1,3,3,$wr, $wi, $vl, $vr, $ilo, $ihi, $scale, $abnrm,$rconde, $rcondv, $info); =for bad geevx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *geevx = \&PDL::geevx; =head2 ggev =for sig Signature: ([phys]A(n,n); int jobvl();int jobvr();[phys]B(n,n);[o,phys]alphar(n);[o,phys]alphai(n);[o,phys]beta(n);[o,phys]VL(m,m);[o,phys]VR(p,p);int [o,phys]info()) =for ref Computes for a pair of N-by-N real nonsymmetric matrices (A,B) the generalized eigenvalues, and optionally, the left and/or right generalized eigenvectors. A generalized eigenvalue for a pair of matrices (A,B) is a scalar lambda or a ratio alpha/beta = lambda, such that A - lambda*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0, and even for both being zero. The right eigenvector v(j) corresponding to the eigenvalue lambda(j) of (A,B) satisfies A * v(j) = lambda(j) * B * v(j). The left eigenvector u(j) corresponding to the eigenvalue lambda(j) of (A,B) satisfies u(j)**H * A = lambda(j) * u(j)**H * B . where u(j)**H is the conjugate-transpose of u(j). Arguments ========= jobvl: = 0: do not compute the left generalized eigenvectors; = 1: compute the left generalized eigenvectors. jobvr: = 0: do not compute the right generalized eigenvectors; = 1: compute the right generalized eigenvectors. A: On entry, the matrix A in the pair (A,B). On exit, A has been overwritten. B: On entry, the matrix B in the pair (A,B). On exit, B has been overwritten. alphar: alphai: beta: On exit, (alphar(j) + alphai(j)*i)/beta(j), j=1,...,N, will be the generalized eigenvalues. If alphai(j) is zero, then the j-th eigenvalue is real; if positive, then the j-th and (j+1)-st eigenvalues are a complex conjugate pair, with alphai(j+1) negative. Note: the quotients alphar(j)/beta(j) and alphai(j)/beta(j) may easily over- or underflow, and beta(j) may even be zero. Thus, the user should avoid naively computing the ratio alpha/beta. However, alphar and alphai will be always less than and usually comparable with norm(A) in magnitude, and beta always less than and usually comparable with norm(B). VL: If jobvl = 1, the left eigenvectors u(j) are stored one after another in the columns of VL, in the same order as their eigenvalues. If the j-th eigenvalue is real, then u(j) = VL(:,j), the j-th column of VL. If the j-th and (j+1)-th eigenvalues form a complex conjugate pair, then u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). Each eigenvector will be scaled so the largest component have abs(real part)+abs(imag. part)=1. Not referenced if jobvl = 0. VR: If jobvr = 1, the right eigenvectors v(j) are stored one after another in the columns of VR, in the same order as their eigenvalues. If the j-th eigenvalue is real, then v(j) = VR(:,j), the j-th column of VR. If the j-th and (j+1)-th eigenvalues form a complex conjugate pair, then v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). Each eigenvector will be scaled so the largest component have abs(real part)+abs(imag. part)=1. Not referenced if jobvr = 0. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. = 1,...,N: The QZ iteration failed. No eigenvectors have been calculated, but alphar(j), alphai(j), and beta(j) should be correct for j=info+1,...,N. > N: =N+1: other than QZ iteration failed in hgeqz. =N+2: error return from tgevc. =for example $a = random(5,5); $b = random(5,5); $alphar = zeroes(5); $alphai = zeroes(5); $beta = zeroes(5); $vl = zeroes(5,5); $vr = zeroes(5,5); ggev($a, 1, 1, $b, $alphar, $alphai, $beta, $vl, $vr, ($info=null)); =for bad ggev ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ggev = \&PDL::ggev; =head2 ggevx =for sig Signature: ([io,phys]A(n,n);int balanc();int jobvl();int jobvr();int sense();[io,phys]B(n,n);[o,phys]alphar(n);[o,phys]alphai(n);[o,phys]beta(n);[o,phys]VL(m,m);[o,phys]VR(p,p);int [o,phys]ilo();int [o,phys]ihi();[o,phys]lscale(n);[o,phys]rscale(n);[o,phys]abnrm();[o,phys]bbnrm();[o,phys]rconde(r);[o,phys]rcondv(s);int [o,phys]info()) =for ref Computes for a pair of N-by-N real nonsymmetric matrices (A,B) the generalized eigenvalues, and optionally, the left and/or right generalized eigenvectors. Optionally also, it computes a balancing transformation to improve the conditioning of the eigenvalues and eigenvectors (ilo, ihi, lscale, rscale, abnrm, and bbnrm), reciprocal condition numbers for the eigenvalues (rconde), and reciprocal condition numbers for the right eigenvectors (rcondv). A generalized eigenvalue for a pair of matrices (A,B) is a scalar lambda or a ratio alpha/beta = lambda, such that A - lambda*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0, and even for both being zero. The right eigenvector v(j) corresponding to the eigenvalue lambda(j) of (A,B) satisfies A * v(j) = lambda(j) * B * v(j) . The left eigenvector u(j) corresponding to the eigenvalue lambda(j) of (A,B) satisfies u(j)**H * A = lambda(j) * u(j)**H * B. where u(j)**H is the conjugate-transpose of u(j). Further Details =============== Balancing a matrix pair (A,B) includes, first, permuting rows and columns to isolate eigenvalues, second, applying diagonal similarity transformation to the rows and columns to make the rows and columns as close in norm as possible. The computed reciprocal condition numbers correspond to the balanced matrix. Permuting rows and columns will not change the condition numbers (in exact arithmetic) but diagonal scaling will. For further explanation of balancing, see section 4.11.1.2 of LAPACK Users' Guide. An approximate error bound on the chordal distance between the i-th computed generalized eigenvalue w and the corresponding exact eigenvalue lambda is chord(w, lambda) <= EPS * norm(abnrm, bbnrm) / rconde(I) An approximate error bound for the angle between the i-th computed eigenvector vl(i) or vr(i) is given by EPS * norm(abnrm, bbnrm) / DIF(i). For further explanation of the reciprocal condition numbers rconde and rcondv, see section 4.11 of LAPACK User's Guide. Arguments ========= balanc: Specifies the balance option to be performed. = 0: do not diagonally scale or permute; = 1: permute only; = 2: scale only; = 3: both permute and scale. Computed reciprocal condition numbers will be for the matrices after permuting and/or balancing. Permuting does not change condition numbers (in exact arithmetic), but balancing does. jobvl: = 0: do not compute the left generalized eigenvectors; = 1: compute the left generalized eigenvectors. jobvr: = 0: do not compute the right generalized eigenvectors; = 1: compute the right generalized eigenvectors. sense: Determines which reciprocal condition numbers are computed. = 0: none are computed; = 1: computed for eigenvalues only; = 2: computed for eigenvectors only; = 3: computed for eigenvalues and eigenvectors. A: On entry, the matrix A in the pair (A,B). On exit, A has been overwritten. If jobvl=1 or jobvr=1 or both, then A contains the first part of the real Schur form of the "balanced" versions of the input A and B. B: On entry, the matrix B in the pair (A,B). On exit, B has been overwritten. If jobvl=1 or jobvr=1 or both, then B contains the second part of the real Schur form of the "balanced" versions of the input A and B. alphar: alphai: beta: On exit, (alphar(j) + alphai(j)*i)/beta(j), j=1,...,N, will be the generalized eigenvalues. If alphai(j) is zero, then the j-th eigenvalue is real; if positive, then the j-th and (j+1)-st eigenvalues are a complex conjugate pair, with alphai(j+1) negative. Note: the quotients alphar(j)/beta(j) and alphai(j)/beta(j) may easily over- or underflow, and beta(j) may even be zero. Thus, the user should avoid naively computing the ratio ALPHA/beta. However, alphar and alphai will be always less than and usually comparable with norm(A) in magnitude, and beta always less than and usually comparable with norm(B). vl: If jobvl = 1, the left eigenvectors u(j) are stored one after another in the columns of vl, in the same order as their eigenvalues. If the j-th eigenvalue is real, then u(j) = vl(:,j), the j-th column of vl. If the j-th and (j+1)-th eigenvalues form a complex conjugate pair, then u(j) = vl(:,j)+i*vl(:,j+1) and u(j+1) = vl(:,j)-i*vl(:,j+1). Each eigenvector will be scaled so the largest component have abs(real part) + abs(imag. part) = 1. Not referenced if jobvl = 0. vr: If jobvr = 1, the right eigenvectors v(j) are stored one after another in the columns of vr, in the same order as their eigenvalues. If the j-th eigenvalue is real, then v(j) = vr(:,j), the j-th column of vr. If the j-th and (j+1)-th eigenvalues form a complex conjugate pair, then v(j) = vr(:,j)+i*vr(:,j+1) and v(j+1) = vr(:,j)-i*vr(:,j+1). Each eigenvector will be scaled so the largest component have abs(real part) + abs(imag. part) = 1. Not referenced if jobvr = 0. ilo,ihi:ilo and ihi are integer values such that on exit A(i,j) = 0 and B(i,j) = 0 if i > j and j = 1,...,ilo-1 or i = ihi+1,...,N. If balanc = 0 or 2, ilo = 1 and ihi = N. lscale: Details of the permutations and scaling factors applied to the left side of A and B. If PL(j) is the index of the row interchanged with row j, and DL(j) is the scaling factor applied to row j, then lscale(j) = PL(j) for j = 1,...,ilo-1 = DL(j) for j = ilo,...,ihi = PL(j) for j = ihi+1,...,N. The order in which the interchanges are made is N to ihi+1, then 1 to ilo-1. rscale: Details of the permutations and scaling factors applied to the right side of A and B. If PR(j) is the index of the column interchanged with column j, and DR(j) is the scaling factor applied to column j, then rscale(j) = PR(j) for j = 1,...,ilo-1 = DR(j) for j = ilo,...,ihi = PR(j) for j = ihi+1,...,N The order in which the interchanges are made is N to ihi+1, then 1 to ilo-1. abnrm: The one-norm of the balanced matrix A. bbnrm: The one-norm of the balanced matrix B. rconde: If sense = 1 or 3, the reciprocal condition numbers of the selected eigenvalues, stored in consecutive elements of the array. For a complex conjugate pair of eigenvalues two consecutive elements of rconde are set to the same value. Thus rconde(j), rcondv(j), and the j-th columns of vl and vr all correspond to the same eigenpair (but not in general the j-th eigenpair, unless all eigenpairs are selected). If sense = 2, rconde is not referenced. rcondv: If sense = 2 or 3, the estimated reciprocal condition numbers of the selected eigenvectors, stored in consecutive elements of the array. For a complex eigenvector two consecutive elements of rcondv are set to the same value. If the eigenvalues cannot be reordered to compute rcondv(j), rcondv(j) is set to 0; this can only occur when the true value would be very small anyway. If sense = 1, rcondv is not referenced. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. = 1,...,N: The QZ iteration failed. No eigenvectors have been calculated, but alphar(j), alphai(j), and beta(j) should be correct for j=info+1,...,N. > N: =N+1: other than QZ iteration failed in hgeqz. =N+2: error return from tgevc. =for example $a = random(5,5); $b = random(5,5); $alphar = zeroes(5); $alphai = zeroes(5); $beta = zeroes(5); $vl = zeroes(5,5); $vr = zeroes(5,5); $lscale = zeroes(5); $rscale = zeroes(5); $ilo = null; $ihi = null; $abnrm = null; $bbnrm = null; $rconde = zeroes(5); $rcondv = zeroes(5); ggevx($a, 3, 1, 1, 3, $b, $alphar, $alphai, $beta, $vl, $vr, $ilo, $ihi, $lscale, $rscale, $abnrm, $bbnrm, $rconde,$rcondv,($info=null)); =for bad ggevx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ggevx = \&PDL::ggevx; =head2 gees =for sig Signature: ([io,phys]A(n,n); int jobvs(); int sort(); [o,phys]wr(n); [o,phys]wi(n); [o,phys]vs(p,p); int [o,phys]sdim(); int [o,phys]info(); SV* select_func) =for ref Computes for an N-by-N real nonsymmetric matrix A, the eigenvalues, the real Schur form T, and, optionally, the matrix of Schur vectors Z. This gives the Schur factorization A = Z*T*Z'. Optionally, it also orders the eigenvalues on the diagonal of the real Schur form so that selected eigenvalues are at the top left. The leading columns of Z then form an orthonormal basis for the invariant subspace corresponding to the selected eigenvalues. A matrix is in real Schur form if it is upper quasi-triangular with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the form [ a b ] [ c a ] where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). Arguments ========= jobvs: = 0: Schur vectors are not computed; = 1: Schur vectors are computed. sort: Specifies whether or not to order the eigenvalues on the diagonal of the Schur form. = 0: Eigenvalues are not ordered; = 1: Eigenvalues are ordered (see select_func). select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form. If sort = 0, select_func is not referenced. An eigenvalue wr(j)+sqrt(-1)*wi(j) is selected if select_func(SCALAR(wr(j)), SCALAR(wi(j))) is true; i.e., if either one of a complex conjugate pair of eigenvalues is selected, then both complex eigenvalues are selected. Note that a selected complex eigenvalue may no longer satisfy select_func(wr(j),wi(j)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info is set to N+2 (see info below). A: The N-by-N matrix A. On exit, A has been overwritten by its real Schur form T. sdim: If sort = 0, sdim = 0. If sort = 1, sdim = number of eigenvalues (after sorting) for which select_func is true. (Complex conjugate pairs for which select_func is true for either eigenvalue count as 2.) wr: wi: wr and wi contain the real and imaginary parts, respectively, of the computed eigenvalues in the same order that they appear on the diagonal of the output Schur form T. Complex conjugate pairs of eigenvalues will appear consecutively with the eigenvalue having the positive imaginary part first. vs: If jobvs = 1, vs contains the orthogonal matrix Z of Schur vectors else vs is not referenced. info = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: if info = i, and i is <= N: the QR algorithm failed to compute all the eigenvalues; elements 1:ILO-1 and i+1:N of wr and wi contain those eigenvalues which have converged; if jobvs = 1, vs contains the matrix which reduces A to its partially converged Schur form. = N+1: the eigenvalues could not be reordered because some eigenvalues were too close to separate (the problem is very ill-conditioned); = N+2: after reordering, roundoff changed values of some complex eigenvalues so that leading eigenvalues in the Schur form no longer satisfy select_func = 1 This could also be caused by underflow due to scaling. =for example sub select_function{ my ($a, $b ) = @_; # Stable "continuous time" eigenspace return $a < 0 ? 1 : 0; } $A = random (5,5); $wr= zeroes(5); $wi = zeroes(5); $vs = zeroes(5,5); $sdim = null; $info = null; gees($A, 1,1, $wr, $wi, $vs, $sdim, $info,\&select_function); =for bad gees ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gees = \&PDL::gees; =head2 geesx =for sig Signature: ([io,phys]A(n,n); int jobvs(); int sort(); int sense(); [o,phys]wr(n); [o,phys]wi(n); [o,phys]vs(p,p); int [o,phys]sdim(); [o,phys]rconde();[o,phys]rcondv(); int [o,phys]info(); SV* select_func) =for ref Computes for an N-by-N real nonsymmetric matrix A, the eigenvalues, the real Schur form T, and, optionally, the matrix of Schur vectors Z. This gives the Schur factorization A = Z*T*Z'. Optionally, it also orders the eigenvalues on the diagonal of the real Schur form so that selected eigenvalues are at the top left; computes a reciprocal condition number for the average of the selected eigenvalues (rconde); and computes a reciprocal condition number for the right invariant subspace corresponding to the selected eigenvalues (rcondv). The leading columns of Z form an orthonormal basis for this invariant subspace. For further explanation of the reciprocal condition numbers rconde and rcondv, see Section 4.10 of the LAPACK Users' Guide (where these quantities are called s and sep respectively). A real matrix is in real Schur form if it is upper quasi-triangular with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the form [ a b ] [ c a ] where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). Arguments ========= jobvs: = 0: Schur vectors are not computed; = 1: Schur vectors are computed. sort: Specifies whether or not to order the eigenvalues on the diagonal of the Schur form. = 0: Eigenvalues are not ordered; = 1: Eigenvalues are ordered (see select_func). select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form else select_func is not referenced. An eigenvalue wr(j)+sqrt(-1)*wi(j) is selected if select_func(wr(j),wi(j)) is true; i.e., if either one of a complex conjugate pair of eigenvalues is selected, then both are. Note that a selected complex eigenvalue may no longer satisfy select_func(wr(j),wi(j)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info may be set to N+3 (see info below). sense: Determines which reciprocal condition numbers are computed. = 0: None are computed; = 1: Computed for average of selected eigenvalues only; = 2: Computed for selected right invariant subspace only; = 3: Computed for both. If sense = 1, 2 or 3, sort must equal 1. A: On entry, the N-by-N matrix A. On exit, A is overwritten by its real Schur form T. sdim: If sort = 0, sdim = 0. If sort = 1, sdim = number of eigenvalues (after sorting) for which select_func is 1. (Complex conjugate pairs for which select_func is 1 for either eigenvalue count as 2.) wr: wi: wr and wi contain the real and imaginary parts, respectively, of the computed eigenvalues, in the same order that they appear on the diagonal of the output Schur form T. Complex conjugate pairs of eigenvalues appear consecutively with the eigenvalue having the positive imaginary part first. vs If jobvs = 1, vs contains the orthogonal matrix Z of Schur vectors else vs is not referenced. rconde: If sense = 1 or 3, rconde contains the reciprocal condition number for the average of the selected eigenvalues. Not referenced if sense = 0 or 2. rcondv: If sense = 2 or 3, rcondv contains the reciprocal condition number for the selected right invariant subspace. Not referenced if sense = 0 or 1. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: if info = i, and i is <= N: the QR algorithm failed to compute all the eigenvalues; elements 1:ilo-1 and i+1:N of wr and wi contain those eigenvalues which have converged; if jobvs = 1, vs contains the transformation which reduces A to its partially converged Schur form. = N+1: the eigenvalues could not be reordered because some eigenvalues were too close to separate (the problem is very ill-conditioned); = N+2: after reordering, roundoff changed values of some complex eigenvalues so that leading eigenvalues in the Schur form no longer satisfy select_func=1 This could also be caused by underflow due to scaling. =for example sub select_function{ my ($a, $b) = @_; # Stable "discrete time" eigenspace return sqrt($a**2 + $b**2) < 1 ? 1 : 0; } $A = random (5,5); $wr= zeroes(5); $wi = zeroes(5); $vs = zeroes(5,5); $sdim = null; $rconde = null; $rcondv = null; $info = null; geesx($A, 1,1, 3, $wr, $wi, $vs, $sdim, $rconde, $rcondv, $info, \&select_function); =for bad geesx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *geesx = \&PDL::geesx; =head2 gges =for sig Signature: ([io,phys]A(n,n); int jobvsl();int jobvsr();int sort();[io,phys]B(n,n);[o,phys]alphar(n);[o,phys]alphai(n);[o,phys]beta(n);[o,phys]VSL(m,m);[o,phys]VSR(p,p);int [o,phys]sdim();int [o,phys]info(); SV* select_func) =for ref Computes for a pair of N-by-N real nonsymmetric matrices (A,B), the generalized eigenvalues, the generalized real Schur form (S,T), optionally, the left and/or right matrices of Schur vectors (VSL and VSR). This gives the generalized Schur factorization (A,B) = ( (VSL)*S*(VSR)', (VSL)*T*(VSR)' ) Optionally, it also orders the eigenvalues so that a selected cluster of eigenvalues appears in the leading diagonal blocks of the upper quasi-triangular matrix S and the upper triangular matrix T.The leading columns of VSL and VSR then form an orthonormal basis for the corresponding left and right eigenspaces (deflating subspaces). (If only the generalized eigenvalues are needed, use the driver ggev instead, which is faster.) A generalized eigenvalue for a pair of matrices (A,B) is a scalar w or a ratio alpha/beta = w, such that A - w*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0 or both being zero. A pair of matrices (S,T) is in generalized real Schur form if T is upper triangular with non-negative diagonal and S is block upper triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond to real generalized eigenvalues, while 2-by-2 blocks of S will be "standardized" by making the corresponding elements of T have the form: [ a 0 ] [ 0 b ] and the pair of corresponding 2-by-2 blocks in S and T will have a complex conjugate pair of generalized eigenvalues. Arguments ========= jobvsl: = 0: do not compute the left Schur vectors; = 1: compute the left Schur vectors. jobvsr: = 0: do not compute the right Schur vectors; = 1: compute the right Schur vectors. sort: Specifies whether or not to order the eigenvalues on the diagonal of the generalized Schur form. = 0: Eigenvalues are not ordered; = 1: Eigenvalues are ordered (see delztg); delztg: If sort = 0, delztg is not referenced. If sort = 1, delztg is used to select eigenvalues to sort to the top left of the Schur form. An eigenvalue (alphar(j)+alphai(j))/beta(j) is selected if delztg(alphar(j),alphai(j),beta(j)) is true; i.e. if either one of a complex conjugate pair of eigenvalues is selected, then both complex eigenvalues are selected. Note that in the ill-conditioned case, a selected complex eigenvalue may no longer satisfy delztg(alphar(j),alphai(j), beta(j)) = 1 after ordering. info is to be set to N+2 in this case. A: On entry, the first of the pair of matrices. On exit, A has been overwritten by its generalized Schur form S. B: On entry, the second of the pair of matrices. On exit, B has been overwritten by its generalized Schur form T. sdim: If sort = 0, sdim = 0. If sort = 1, sdim = number of eigenvalues (after sorting) for which delztg is true. (Complex conjugate pairs for which delztg is true for either eigenvalue count as 2.) alphar: alphai: beta: On exit, (alphar(j) + alphai(j)*i)/beta(j), j=1,...,N, will be the generalized eigenvalues. alphar(j) + alphai(j)*i, and beta(j),j=1,...,N are the diagonals of the complex Schur form (S,T) that would result if the 2-by-2 diagonal blocks of the real Schur form of (A,B) were further reduced to triangular form using 2-by-2 complex unitary transformations. If alphai(j) is zero, then the j-th eigenvalue is real; if positive, then the j-th and (j+1)-st eigenvalues are a complex conjugate pair, with alphai(j+1) negative. Note: the quotients alphar(j)/beta(j) and alphai(j)/beta(j) may easily over- or underflow, and beta(j) may even be zero. Thus, the user should avoid naively computing the ratio. However, alphar and alphai will be always less than and usually comparable with norm(A) in magnitude, and beta always less than and usually comparable with norm(B). VSL: If jobvsl = 1, VSL will contain the left Schur vectors. Not referenced if jobvsl = 0. The leading dimension must always be >=1. VSR: If jobvsr = 1, VSR will contain the right Schur vectors. Not referenced if jobvsr = 0. The leading dimension must always be >=1. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. = 1,...,N: The QZ iteration failed. (A,B) are not in Schur form, but alphar(j), alphai(j), and beta(j) should be correct for j=info+1,...,N. > N: =N+1: other than QZ iteration failed in hgeqz. =N+2: after reordering, roundoff changed values of some complex eigenvalues so that leading eigenvalues in the Generalized Schur form no longer satisfy delztg=1 This could also be caused due to scaling. =N+3: reordering failed in tgsen. =for example sub my_select{ my ($zr, $zi, $d) = @_; # stable generalized eigenvalues for continuous time return ( ($zr < 0 && $d > 0 ) || ($zr > 0 && $d < 0) ) ? 1 : 0; } $a = random(5,5); $b = random(5,5); $sdim = null; $alphar = zeroes(5); $alphai = zeroes(5); $beta = zeroes(5); $vsl = zeroes(5,5); $vsr = zeroes(5,5); gges($a, 1, 1, 1, $b, $alphar, $alphai, $beta, $vsl, $vsr, $sdim,($info=null), \&my_select); =for bad gges ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gges = \&PDL::gges; =head2 ggesx =for sig Signature: ([io,phys]A(n,n); int jobvsl();int jobvsr();int sort();int sense();[io,phys]B(n,n);[o,phys]alphar(n);[o,phys]alphai(n);[o,phys]beta(n);[o,phys]VSL(m,m);[o,phys]VSR(p,p);int [o,phys]sdim();[o,phys]rconde(q);[o,phys]rcondv(r);int [o,phys]info(); SV* select_func) =for ref Computes for a pair of N-by-N real nonsymmetric matrices (A,B), the generalized eigenvalues, the real Schur form (S,T), and, optionally, the left and/or right matrices of Schur vectors (VSL and VSR). This gives the generalized Schur factorization (A,B) = ( (VSL) S (VSR)', (VSL) T (VSR)' ) Optionally, it also orders the eigenvalues so that a selected cluster of eigenvalues appears in the leading diagonal blocks of the upper quasi-triangular matrix S and the upper triangular matrix T; computes a reciprocal condition number for the average of the selected eigenvalues (RCONDE); and computes a reciprocal condition number for the right and left deflating subspaces corresponding to the selected eigenvalues (RCONDV). The leading columns of VSL and VSR then form an orthonormal basis for the corresponding left and right eigenspaces (deflating subspaces). A generalized eigenvalue for a pair of matrices (A,B) is a scalar w or a ratio alpha/beta = w, such that A - w*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0 or for both being zero. A pair of matrices (S,T) is in generalized real Schur form if T is upper triangular with non-negative diagonal and S is block upper triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond to real generalized eigenvalues, while 2-by-2 blocks of S will be "standardized" by making the corresponding elements of T have the form: [ a 0 ] [ 0 b ] and the pair of corresponding 2-by-2 blocks in S and T will have a complex conjugate pair of generalized eigenvalues. Further details =============== An approximate (asymptotic) bound on the average absolute error of the selected eigenvalues is EPS * norm((A, B)) / RCONDE( 1 ). An approximate (asymptotic) bound on the maximum angular error in the computed deflating subspaces is EPS * norm((A, B)) / RCONDV( 2 ). See LAPACK User's Guide, section 4.11 for more information. Arguments ========= jobvsl: = 0: do not compute the left Schur vectors; = 1: compute the left Schur vectors. jobvsr: = 0: do not compute the right Schur vectors; = 1: compute the right Schur vectors. sort: Specifies whether or not to order the eigenvalues on the diagonal of the generalized Schur form. = 0: Eigenvalues are not ordered; = 1: Eigenvalues are ordered (see delztg); delztg: If sort = 0, delztg is not referenced. If sort = 1, delztg is used to select eigenvalues to sort to the top left of the Schur form. An eigenvalue (alphar(j)+alphai(j))/beta(j) is selected if delztg(alphar(j),alphai(j),beta(j)) is true; i.e. if either one of a complex conjugate pair of eigenvalues is selected, then both complex eigenvalues are selected. Note that in the ill-conditioned case, a selected complex eigenvalue may no longer satisfy delztg(alphar(j),alphai(j), beta(j)) = 1 after ordering. info is to be set to N+2 in this case. sense: Determines which reciprocal condition numbers are computed. = 0 : None are computed; = 1 : Computed for average of selected eigenvalues only; = 2 : Computed for selected deflating subspaces only; = 3 : Computed for both. If sense = 1, 2, or 3, sort must equal 1. A: On entry, the first of the pair of matrices. On exit, A has been overwritten by its generalized Schur form S. B: On entry, the second of the pair of matrices. On exit, B has been overwritten by its generalized Schur form T. sdim: If sort = 0, sdim = 0. If sort = 1, sdim = number of eigenvalues (after sorting) for which delztg is true. (Complex conjugate pairs for which delztg is true for either eigenvalue count as 2.) alphar: alphai: beta: On exit, (alphar(j) + alphai(j)*i)/beta(j), j=1,...,N, will be the generalized eigenvalues. alphar(j) + alphai(j)*i, and beta(j),j=1,...,N are the diagonals of the complex Schur form (S,T) that would result if the 2-by-2 diagonal blocks of the real Schur form of (A,B) were further reduced to triangular form using 2-by-2 complex unitary transformations. If alphai(j) is zero, then the j-th eigenvalue is real; if positive, then the j-th and (j+1)-st eigenvalues are a complex conjugate pair, with alphai(j+1) negative. Note: the quotients alphar(j)/beta(j) and alphai(j)/beta(j) may easily over- or underflow, and beta(j) may even be zero. Thus, the user should avoid naively computing the ratio. However, alphar and alphai will be always less than and usually comparable with norm(A) in magnitude, and beta always less than and usually comparable with norm(B). VSL: If jobvsl = 1, VSL will contain the left Schur vectors. Not referenced if jobvsl = 0. The leading dimension must always be >=1. VSR: If jobvsr = 1, VSR will contain the right Schur vectors. Not referenced if jobvsr = 0. The leading dimension must always be >=1. rconde: If sense = 1 or 3, rconde(1) and rconde(2) contain the reciprocal condition numbers for the average of the selected eigenvalues. Not referenced if sense = 0 or 2. rcondv: If sense = 2 or 3, rcondv(1) and rcondv(2) contain the reciprocal condition numbers for the selected deflating subspaces. Not referenced if sense = 0 or 1. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. = 1,...,N: The QZ iteration failed. (A,B) are not in Schur form, but alphar(j), alphai(j), and beta(j) should be correct for j=info+1,...,N. > N: =N+1: other than QZ iteration failed in hgeqz. =N+2: after reordering, roundoff changed values of some complex eigenvalues so that leading eigenvalues in the Generalized Schur form no longer satisfy delztg=1 This could also be caused due to scaling. =N+3: reordering failed in tgsen. =for example sub my_select{ my ($zr, $zi, $d) = @_; # Eigenvalue : (ZR/D) + sqrt(-1)*(ZI/D) # stable generalized eigenvalues for discrete time return (sqrt($zr**2 + $zi**2) < abs($d) ) ? 1 : 0; } $a = random(5,5); $b = random(5,5); $sdim = null; $alphar = zeroes(5); $alphai = zeroes(5); $beta = zeroes(5); $vsl = zeroes(5,5); $vsr = zeroes(5,5); $rconde = zeroes(2); $rcondv = zeroes(2); ggesx($a, 1, 1, 1, 3,$b, $alphar, $alphai, $beta, $vsl, $vsr, $sdim, $rconde, $rcondv, ($info=null), \&my_select); =for bad ggesx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ggesx = \&PDL::ggesx; =head2 syev =for sig Signature: ([io,phys]A(n,n); int jobz(); int uplo(); [o,phys]w(n); int [o,phys]info()) =for ref Computes all eigenvalues and, optionally, eigenvectors of a real symmetric matrix A. Arguments ========= jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. uplo = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, if jobz = 1, then if info = 0, A contains the orthonormal eigenvectors of the matrix A. If jobz = 0, then on exit the lower triangle (if uplo=1) or the upper triangle (if uplo=0) of A, including the diagonal, is destroyed. w: If info = 0, the eigenvalues in ascending order. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the algorithm failed to converge; i off-diagonal elements of an intermediate tridiagonal form did not converge to zero. =for example # Assume $a is symmetric ;) $a = random (5,5); syev($a, 1,1, (my $w = zeroes(5)), (my $info=null)); =for bad syev ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *syev = \&PDL::syev; =head2 syevd =for sig Signature: ([io,phys]A(n,n); int jobz(); int uplo(); [o,phys]w(n); int [o,phys]info()) =for ref Computes all eigenvalues and, optionally, eigenvectors of a real symmetric matrix A. If eigenvectors are desired, it uses a divide and conquer algorithm. The divide and conquer algorithm makes very mild assumptions about floating point arithmetic. It will work on machines with a guard digit in add/subtract, or on those binary machines without guard digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. It could conceivably fail on hexadecimal or decimal machines without guard digits, but we know of none. Because of large use of BLAS of level 3, syevd needs N**2 more workspace than syevx. Arguments ========= jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. uplo = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, if jobz = 1, then if info = 0, A contains the orthonormal eigenvectors of the matrix A. If jobz = 0, then on exit the lower triangle (if uplo=1) or the upper triangle (if uplo=0) of A, including the diagonal, is destroyed. w: If info = 0, the eigenvalues in ascending order. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the algorithm failed to converge; i off-diagonal elements of an intermediate tridiagonal form did not converge to zero. =for example # Assume $a is symmetric ;) $a = random (5,5); syevd($a, 1,1, (my $w = zeroes(5)), (my $info=null)); =for bad syevd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *syevd = \&PDL::syevd; =head2 syevx =for sig Signature: ([phys]A(n,n); int jobz(); int range(); int uplo(); [phys]vl(); [phys]vu(); int [phys]il(); int [phys]iu(); [phys]abstol(); int [o,phys]m(); [o,phys]w(n); [o,phys]z(p,q);int [o,phys]ifail(r); int [o,phys]info()) =for ref Computes selected eigenvalues and, optionally, eigenvectors of a real symmetric matrix A. Eigenvalues and eigenvectors can be selected by specifying either a range of values or a range of indices for the desired eigenvalues. Arguments ========= jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. range: = 0: all eigenvalues will be found. = 1: all eigenvalues in the half-open interval (vl,vu] will be found. = 1: the il-th through iu-th eigenvalues will be found. uplo = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, the lower triangle (if uplo=1) or the upper triangle (if uplo=0) of A, including the diagonal, is destroyed. vl: vu: If range=1, the lower and upper bounds of the interval to be searched for eigenvalues. vl < vu. Not referenced if range = 0 or 2. il: iu: If range=2, the indices (in ascending order) of the smallest and largest eigenvalues to be returned. 1 <= il <= iu <= N, if N > 0; il = 1 and iu = 0 if N = 0. Not referenced if range = 0 or 1. abstol: The absolute error tolerance for the eigenvalues. An approximate eigenvalue is accepted as converged when it is determined to lie in an interval [a,b] of width less than or equal to abstol + EPS * max( |a|,|b| ) , where EPS is the machine precision. If abstol is less than or equal to zero, then EPS*|T| will be used in its place, where |T| is the 1-norm of the tridiagonal matrix obtained by reducing A to tridiagonal form. Eigenvalues will be computed most accurately when abstol is set to twice the underflow threshold 2*lamch(1), not zero. If this routine returns with info>0, indicating that some eigenvectors did not converge, try setting abstol to 2*lamch(1). See "Computing Small Singular Values of Bidiagonal Matrices with Guaranteed High Relative Accuracy," by Demmel and Kahan, LAPACK Working Note #3. m: The total number of eigenvalues found. 0 <= m <= N. If range = 0, m = N, and if range = 2, m = iu-il+1. w: On normal exit, the first M elements contain the selected eigenvalues in ascending order. z: If jobz = 1, then if info = 0, the first m columns of z contain the orthonormal eigenvectors of the matrix A corresponding to the selected eigenvalues, with the i-th column of z holding the eigenvector associated with w(i). If an eigenvector fails to converge, then that column of z contains the latest approximation to the eigenvector, and the index of the eigenvector is returned in ifail. If jobz = 0, then z is not referenced. Note: the user must ensure that at least max(1,m) columns are supplied in the array z; if range = 1, the exact value of m is not known in advance and an upper bound must be used. ifail: If jobz = 1, then if info = 0, the first m elements of ifail are zero. If info > 0, then ifail contains the indices of the eigenvectors that failed to converge. If jobz = 0, then ifail is not referenced. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, then i eigenvectors failed to converge. Their indices are stored in array ifail. =for example # Assume $a is symmetric ;) $a = random (5,5); $unfl = lamch(1); $ovfl = lamch(9); labad($unfl, $ovfl); $abstol = $unfl + $unfl; $m = null; $info = null; $ifail = zeroes(5); $w = zeroes(5); $z = zeroes(5,5); syevx($a, 1,0,1,0,0,0,0,$abstol, $m, $w, $z ,$ifail, $info); =for bad syevx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *syevx = \&PDL::syevx; =head2 syevr =for sig Signature: ([phys]A(n,n); int jobz(); int range(); int uplo(); [phys]vl(); [phys]vu(); int [phys]il(); int [phys]iu();[phys]abstol();int [o,phys]m();[o,phys]w(n); [o,phys]z(p,q);int [o,phys]isuppz(r); int [o,phys]info()) =for ref Computes selected eigenvalues and, optionally, eigenvectors of a real symmetric matrix T. Eigenvalues and eigenvectors can be selected by specifying either a range of values or a range of indices for the desired eigenvalues. Whenever possible, syevr calls stegr to compute the eigenspectrum using Relatively Robust Representations. stegr computes eigenvalues by the dqds algorithm, while orthogonal eigenvectors are computed from various "good" L D L^T representations (also known as Relatively Robust Representations). Gram-Schmidt orthogonalization is avoided as far as possible. More specifically, the various steps of the algorithm are as follows. For the i-th unreduced block of T, (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T is a relatively robust representation, (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high relative accuracy by the dqds algorithm, (c) If there is a cluster of close eigenvalues, "choose" sigma_i close to the cluster, and go to step (a), (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, compute the corresponding eigenvector by forming a rank-revealing twisted factorization. The desired accuracy of the output can be specified by the input parameter abstol. For more details, see "A new O(n^2) algorithm for the symmetric tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, Computer Science Division Technical Report No. UCB//CSD-97-971, UC Berkeley, May 1997. Note 1 : syevr calls stegr when the full spectrum is requested on machines which conform to the ieee-754 floating point standard. syevr calls stebz and stein on non-ieee machines and when partial spectrum requests are made. Normal execution of stegr may create NaNs and infinities and hence may abort due to a floating point exception in environments which do not handle NaNs and infinities in the ieee standard default manner. Arguments ========= jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. range: = 0: all eigenvalues will be found. = 1: all eigenvalues in the half-open interval (vl,vu] will be found. = 2: the il-th through iu-th eigenvalues will be found. ********* For range = 1 or 2 and iu - il < N - 1, stebz and ********* stein are called uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, the lower triangle (if uplo=1) or the upper triangle (if uplo=0) of A, including the diagonal, is destroyed. vl: vu: If range=1, the lower and upper bounds of the interval to be searched for eigenvalues. vl < vu. Not referenced if range = 0 or 2. il: iu: If range=2, the indices (in ascending order) of the smallest and largest eigenvalues to be returned. 1 <= il <= iu <= N, if N > 0; il = 1 and iu = 0 if N = 0. Not referenced if range = 0 or 1. abstol: The absolute error tolerance for the eigenvalues. An approximate eigenvalue is accepted as converged when it is determined to lie in an interval [a,b] of width less than or equal to abstol + EPS * max( |a|,|b| ) , where EPS is the machine precision. If abstol is less than or equal to zero, then EPS*|T| will be used in its place, where |T| is the 1-norm of the tridiagonal matrix obtained by reducing A to tridiagonal form. See "Computing Small Singular Values of Bidiagonal Matrices with Guaranteed High Relative Accuracy," by Demmel and Kahan, LAPACK Working Note #3. If high relative accuracy is important, set abstol to lamch(1). Doing so will guarantee that eigenvalues are computed to high relative accuracy when possible in future releases. The current code does not make any guarantees about high relative accuracy, but furure releases will. See J. Barlow and J. Demmel, "Computing Accurate Eigensystems of Scaled Diagonally Dominant Matrices", LAPACK Working Note #7, for a discussion of which matrices define their eigenvalues to high relative accuracy. m: The total number of eigenvalues found. 0 <= m <= N. If range = 0, m = N, and if range = 2, m = iu-il+1. w: The first m elements contain the selected eigenvalues in ascending order. z: If jobz = 1, then if info = 0, the first m columns of z contain the orthonormal eigenvectors of the matrix A corresponding to the selected eigenvalues, with the i-th column of z holding the eigenvector associated with w(i). If jobz = 0, then z is not referenced. Note: the user must ensure that at least max(1,m) columns are supplied in the array z; if range = 1, the exact value of m is not known in advance and an upper bound must be used. isuppz: array of int, dimension ( 2*max(1,m) ) The support of the eigenvectors in z, i.e., the indices indicating the nonzero elements in z. The i-th eigenvector is nonzero only in elements isuppz( 2*i-1 ) through isuppz( 2*i ). ********* Implemented only for range = 0 or 2 and iu - il = N - 1 info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: Internal error =for example # Assume $a is symmetric ;) $a = random (5,5); $unfl = lamch(1); $ovfl = lamch(9); labad($unfl, $ovfl); $abstol = $unfl + $unfl; $m = null; $info = null; $isuppz = zeroes(10); $w = zeroes(5); $z = zeroes(5,5); syevr($a, 1,0,1,0,0,0,0,$abstol, $m, $w, $z ,$isuppz, $info); =for bad syevr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *syevr = \&PDL::syevr; =head2 sygv =for sig Signature: ([io,phys]A(n,n);int [phys]itype();int jobz(); int uplo();[io,phys]B(n,n);[o,phys]w(n); int [o,phys]info()) =for ref Computes all the eigenvalues, and optionally, the eigenvectors of a real generalized symmetric-definite eigenproblem, of the form A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and B are assumed to be symmetric and B is also positive definite. Arguments ========= itype: Specifies the problem type to be solved: = 1: A*x = (lambda)*B*x = 2: A*B*x = (lambda)*x = 3: B*A*x = (lambda)*x jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. uplo: = 0: Upper triangles of A and B are stored; = 1: Lower triangles of A and B are stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, if jobz = 1, then if info = 0, A contains the matrix Z of eigenvectors. The eigenvectors are normalized as follows: if itype = 1 or 2, Z'*B*Z = I; if itype = 3, Z'*inv(B)*Z = I. If jobz = 0, then on exit the upper triangle (if uplo=0) or the lower triangle (if uplo=1) of A, including the diagonal, is destroyed. B: On entry, the symmetric positive definite matrix B. If uplo = 0, the leading N-by-N upper triangular part of B contains the upper triangular part of the matrix B. If uplo = 1, the leading N-by-N lower triangular part of B contains the lower triangular part of the matrix B. On exit, if info <= N, the part of B containing the matrix is overwritten by the triangular factor U or L from the Cholesky factorization B = U'*U or B = L*L'. W: If info = 0, the eigenvalues in ascending order. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: potrf or syev returned an error code: <= N: if info = i, syev failed to converge; i off-diagonal elements of an intermediate tridiagonal form did not converge to zero; > N: if info = N + i, for 1 <= i <= N, then the leading minor of order i of B is not positive definite. The factorization of B could not be completed and no eigenvalues or eigenvectors were computed. =for example # Assume $a is symmetric ;) $a = random (5,5); # Assume $a is symmetric and positive definite ;) $b = random (5,5); sygv($a, 1,1, 0, $b, (my $w = zeroes(5)), (my $info=null)); =for bad sygv ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sygv = \&PDL::sygv; =head2 sygvd =for sig Signature: ([io,phys]A(n,n);int [phys]itype();int jobz(); int uplo();[io,phys]B(n,n);[o,phys]w(n); int [o,phys]info()) =for ref Computes all the eigenvalues, and optionally, the eigenvectors of a real generalized symmetric-definite eigenproblem, of the form A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and B are assumed to be symmetric and B is also positive definite. The divide and conquer algorithm makes very mild assumptions about floating point arithmetic. It will work on machines with a guard digit in add/subtract, or on those binary machines without guard digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. It could conceivably fail on hexadecimal or decimal machines without guard digits, but we know of none. Arguments ========= itype: Specifies the problem type to be solved: = 1: A*x = (lambda)*B*x = 2: A*B*x = (lambda)*x = 3: B*A*x = (lambda)*x jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. uplo: = 0: Upper triangles of A and B are stored; = 1: Lower triangles of A and B are stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, if jobz = 1, then if info = 0, A contains the matrix Z of eigenvectors. The eigenvectors are normalized as follows: if itype = 1 or 2, Z'*B*Z = I; if itype = 3, Z'*inv(B)*Z = I. If jobz = 0, then on exit the upper triangle (if uplo=0) or the lower triangle (if uplo=1) of A, including the diagonal, is destroyed. B: On entry, the symmetric positive definite matrix B. If uplo = 0, the leading N-by-N upper triangular part of B contains the upper triangular part of the matrix B. If uplo = 1, the leading N-by-N lower triangular part of B contains the lower triangular part of the matrix B. On exit, if info <= N, the part of B containing the matrix is overwritten by the triangular factor U or L from the Cholesky factorization B = U'*U or B = L*L'. W: If info = 0, the eigenvalues in ascending order. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: potrf or syev returned an error code: <= N: if info = i, syevd failed to converge; i off-diagonal elements of an intermediate tridiagonal form did not converge to zero; > N: if info = N + i, for 1 <= i <= N, then the leading minor of order i of B is not positive definite. The factorization of B could not be completed and no eigenvalues or eigenvectors were computed. =for example # Assume $a is symmetric ;) $a = random (5,5); # Assume $b is symmetric positive definite ;) $b = random (5,5); sygvd($a, 1,1, 0, $b, (my $w = zeroes(5)), (my $info=null)); =for bad sygvd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sygvd = \&PDL::sygvd; =head2 sygvx =for sig Signature: ([io,phys]A(n,n);int [phys]itype();int jobz();int range(); int uplo();[io,phys]B(n,n);[phys]vl();[phys]vu();int [phys]il();int [phys]iu();[phys]abstol();int [o,phys]m();[o,phys]w(n); [o,phys]Z(p,q);int [o,phys]ifail(r);int [o,phys]info()) =for ref Computes selected eigenvalues, and optionally, eigenvectors of a real generalized symmetric-definite eigenproblem, of the form A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and B are assumed to be symmetric and B is also positive definite. Eigenvalues and eigenvectors can be selected by specifying either a range of values or a range of indices for the desired eigenvalues. Arguments ========= itype: Specifies the problem type to be solved: = 1: A*x = (lambda)*B*x = 2: A*B*x = (lambda)*x = 3: B*A*x = (lambda)*x jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. range: = 0: all eigenvalues will be found. = 1: all eigenvalues in the half-open interval (vl,vu] will be found. = 2: the il-th through iu-th eigenvalues will be found. uplo: = 0: Upper triangle of A and B are stored; = 1: Lower triangle of A and B are stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, the lower triangle (if uplo=1) or the upper triangle (if uplo=0) of A, including the diagonal, is destroyed. B: On entry, the symmetric matrix B. If uplo = 0, the leading N-by-N upper triangular part of B contains the upper triangular part of the matrix B. If uplo = 1, the leading N-by-N lower triangular part of B contains the lower triangular part of the matrix B. On exit, if info <= N, the part of B containing the matrix is overwritten by the triangular factor U or L from the Cholesky factorization B = U'*U or B = L*L'. vl: vu: If range=1, the lower and upper bounds of the interval to be searched for eigenvalues. vl < vu. Not referenced if range = 0 or 2. il: iu: If range=2, the indices (in ascending order) of the smallest and largest eigenvalues to be returned. 1 <= il <= iu <= N, if N > 0; il = 1 and iu = 0 if N = 0. Not referenced if range = 0 or 1. abstol: The absolute error tolerance for the eigenvalues. An approximate eigenvalue is accepted as converged when it is determined to lie in an interval [a,b] of width less than or equal to abstol + EPS * max( |a|,|b| ) , where EPS is the machine precision. If abstol is less than or equal to zero, then EPS*|T| will be used in its place, where |T| is the 1-norm of the tridiagonal matrix obtained by reducing A to tridiagonal form. Eigenvalues will be computed most accurately when abstol is set to twice the underflow threshold 2*lamch(1), not zero. If this routine returns with info>0, indicating that some eigenvectors did not converge, try setting abstol to 2* lamch(1). m: The total number of eigenvalues found. 0 <= m <= N. If range = 0, m = N, and if range = 2, m = iu-il+1. w: On normal exit, the first m elements contain the selected eigenvalues in ascending order. Z: If jobz = 0, then Z is not referenced. If jobz = 1, then if info = 0, the first m columns of Z contain the orthonormal eigenvectors of the matrix A corresponding to the selected eigenvalues, with the i-th column of Z holding the eigenvector associated with w(i). The eigenvectors are normalized as follows: if itype = 1 or 2, Z'*B*Z = I; if itype = 3, Z'*inv(B)*Z = I. If an eigenvector fails to converge, then that column of Z contains the latest approximation to the eigenvector, and the index of the eigenvector is returned in ifail. Note: the user must ensure that at least max(1,m) columns are supplied in the array Z; if range = 1, the exact value of m is not known in advance and an upper bound must be used. ifail: If jobz = 1, then if info = 0, the first M elements of ifail are zero. If info > 0, then ifail contains the indices of the eigenvectors that failed to converge. If jobz = 0, then ifail is not referenced. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: potrf or syevx returned an error code: <= N: if info = i, syevx failed to converge; i eigenvectors failed to converge. Their indices are stored in array ifail. > N: if info = N + i, for 1 <= i <= N, then the leading minor of order i of B is not positive definite. The factorization of B could not be completed and no eigenvalues or eigenvectors were computed. =for example # Assume $a is symmetric ;) $a = random (5,5); # Assume $b is symmetric positive definite ;) $b = random (5,5); $unfl = lamch(1); $ovfl = lamch(9); labad($unfl, $ovfl); $abstol = $unfl + $unfl; $m = null; $w=zeroes(5); $z = zeroes(5,5); $ifail = zeroes(5); sygvx($a, 1,1, 0,0, $b, 0, 0, 0, 0, $abstol, $m, $w, $z,$ifail,(my $info=null)); =for bad sygvx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sygvx = \&PDL::sygvx; =head2 gesv =for sig Signature: ([io,phys]A(n,n); [io,phys]B(n,m); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Computes the solution to a real system of linear equations A * X = B, where A is an N-by-N matrix and X and B are N-by-NRHS matrices. The LU decomposition with partial pivoting and row interchanges is used to factor A as A = P * L * U, where P is a permutation matrix, L is unit lower triangular, and U is upper triangular. The factored form of A is then used to solve the system of equations A * X = B. Arguments ========= A: On entry, the N-by-N coefficient matrix A. On exit, the factors L and U from the factorization A = P*L*U; the unit diagonal elements of L are not stored. ipiv: The pivot indices that define the permutation matrix P; row i of the matrix was interchanged with row ipiv(i). B: On entry, the N-by-NRHS matrix of right hand side matrix B. On exit, if info = 0, the N-by-NRHS solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, U(i,i) is exactly zero. The factorization has been completed, but the factor U is exactly singular, so the solution could not be computed. =for example $a = random (5,5); $a = transpose($a); $b = random (5,5); $b = transpose($b); gesv($a,$b, (my $ipiv=zeroes(5)),(my $info=null)); print "The solution matrix X is :". transpose($b)."\n" unless $info; =for bad gesv ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gesv = \&PDL::gesv; =head2 gesvx =for sig Signature: ([io,phys]A(n,n); int trans(); int fact(); [io,phys]B(n,m); [io,phys]af(n,n); int [io,phys]ipiv(n); int [io]equed(); [io,phys]r(n); [io,phys]c(n); [o,phys]X(n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m);[o,phys]rpvgrw();int [o,phys]info()) =for ref Uses the LU factorization to compute the solution to a real system of linear equations A * X = B, where A is an N-by-N matrix and X and B are N-by-NRHS matrices. Error bounds on the solution and a condition estimate are also provided. =for desc The following steps are performed: =over 3 =item 1 If fact = 2, real scaling factors are computed to equilibrate the system: trans = 0: diag(r)*A*diag(c) *inv(diag(c))*X = diag(c)*B trans = 1: (diag(r)*A*diag(c))' *inv(diag(r))*X = diag(c)*B trans = 2: (diag(r)*A*diag(c))**H *inv(diag(r))*X = diag(c)*B Whether or not the system will be equilibrated depends on the scaling of the matrix A, but if equilibration is used, A is overwritten by diag(r)*A*diag(c) and B by diag(r)*B (if trans=0) or diag(c)*B (if trans = 1 or 2). =item 2 If fact = 1 or 2, the LU decomposition is used to factor the matrix A (after equilibration if fact = 2) as A = P * L * U, where P is a permutation matrix, L is a unit lower triangular matrix, and U is upper triangular. =item 3 If some U(i,i)=0, so that U is exactly singular, then the routine returns with info = i. Otherwise, the factored form of A is used to estimate the condition number of the matrix A. If the reciprocal of the condition number is less than machine precision, info = N+1 is returned as a warning, but the routine still goes on to solve for X and compute error bounds as described below. =item 4 The system of equations is solved for X using the factored form of A. =item 5 Iterative refinement is applied to improve the computed solution matrix and calculate error bounds and backward error estimates for it. =item 6 If equilibration was used, the matrix X is premultiplied by diag(c) (if trans = 0) or diag(r) (if trans = 1 or 2) so that it solves the original system before equilibration. =back Arguments ========= fact: Specifies whether or not the factored form of the matrix A is supplied on entry, and if not, whether the matrix A should be equilibrated before it is factored. = 0: On entry, af and ipiv contain the factored form of A. If equed is not 0, the matrix A has been equilibrated with scaling factors given by r and c. A, af, and ipiv are not modified. = 1: The matrix A will be copied to af and factored. = 2: The matrix A will be equilibrated if necessary, then copied to af and factored. trans: Specifies the form of the system of equations: = 0: A * X = B (No transpose) = 1: A' * X = B (Transpose) = 2: A**H * X = B (Transpose) A: On entry, the N-by-N matrix A. If fact = 0 and equed is not 0, then A must have been equilibrated by the scaling factors in r and/or c. A is not modified if fact = 0 or 1, or if fact = 2 and equed = 0 on exit. On exit, if equed != 0, A is scaled as follows: equed = 1: A := diag(r) * A equed = 2: A := A * diag(c) equed = 3: A := diag(r) * A * diag(c). af: If fact = 0, then af is an input argument and on entry contains the factors L and U from the factorization A = P*L*U as computed by getrf. If equed != 0, then af is the factored form of the equilibrated matrix A. If fact = 1, then af is an output argument and on exit returns the factors L and U from the factorization A = P*L*U of the original matrix A. If fact = 2, then af is an output argument and on exit returns the factors L and U from the factorization A = P*L*U of the equilibrated matrix A (see the description of A for the form of the equilibrated matrix). ipiv: If fact = 0, then ipiv is an input argument and on entry contains the pivot indices from the factorization A = P*L*U as computed by getrf; row i of the matrix was interchanged with row ipiv(i). If fact = 1, then ipiv is an output argument and on exit contains the pivot indices from the factorization A = P*L*U of the original matrix A. If fact = 2, then ipiv is an output argument and on exit contains the pivot indices from the factorization A = P*L*U of the equilibrated matrix A. equed: Specifies the form of equilibration that was done. = 0: No equilibration (always true if fact = 1). = 1: Row equilibration, i.e., A has been premultiplied by diag(r). = 2: Column equilibration, i.e., A has been postmultiplied by diag(c). = 3: Both row and column equilibration, i.e., A has been replaced by diag(r) * A * diag(c). equed is an input argument if fact = 0; otherwise, it is an output argument. r: The row scale factors for A. If equed = 1 or 3, A is multiplied on the left by diag(r); if equed = 0 or 2, r is not accessed. r is an input argument if fact = 0; otherwise, r is an output argument. If fact = 0 and equed = 1 or 3, each element of r must be positive. c: The column scale factors for A. If equed = 2 or 3, A is multiplied on the right by diag(c); if equed = 0 or 1, c is not accessed. c is an input argument if fact = 0; otherwise, c is an output argument. If fact = 0 and equed = 2 or 3, each element of c must be positive. B: On entry, the N-by-NRHS right hand side matrix B. On exit, if equed = 0, B is not modified; if trans = 0 and equed = 1 or 3, B is overwritten by diag(r)*B; if trans = 1 or 2 and equed = 2 or 3, B is overwritten by diag(c)*B. X: If info = 0 or info = N+1, the N-by-NRHS solution matrix X to the original system of equations. Note that A and B are modified on exit if equed != 0, and the solution to the equilibrated system is inv(diag(c))*X if trans = 0 and equed = 2 or 3, or inv(diag(r))*X if trans = 1 or 2 and equed = 1 or 3. rcond: The estimate of the reciprocal condition number of the matrix A after equilibration (if done). If rcond is less than the machine precision (in particular, if rcond = 0), the matrix is singular to working precision. This condition is indicated by a return code of info > 0. ferr: The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), ferr(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for rcond, and is almost always a slight overestimate of the true error. berr: The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution). rpvgrw: Contains the reciprocal pivot growth factor norm(A)/norm(U). The "max absolute element" norm is used. If it is much less than 1, then the stability of the LU factorization of the (equilibrated) matrix A could be poor. This also means that the solution X, condition estimator rcond, and forward error bound ferr could be unreliable. If factorization fails with 0 0: if info = i, and i is <= N: U(i,i) is exactly zero. The factorization has been completed, but the factor U is exactly singular, so the solution and error bounds could not be computed. rcond = 0 is returned. = N+1: U is nonsingular, but rcond is less than machine precision, meaning that the matrix is singular to working precision. Nevertheless, the solution and error bounds are computed because there are a number of situations where the computed solution can be more accurate than the value of rcond would suggest. =for example $a= random(5,5); $b = random(5,5); $a = transpose($a); $b = transpose($b); $rcond = pdl(0); $rpvgrw = pdl(0); $equed = pdl(long,0); $info = pdl(long,0); $berr = zeroes(5); $ipiv = zeroes(5); $ferr = zeroes(5); $r = zeroes(5); $c = zeroes(5); $X = zeroes(5,5); $af = zeroes(5,5); gesvx($a,0, 2, $b, $af, $ipiv, $equed, $r, $c, $X, $rcond, $ferr, $berr, $rpvgrw, $info); print "The solution matrix X is :". transpose($X)."\n" unless $info; =for bad gesvx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gesvx = \&PDL::gesvx; =head2 sysv =for sig Signature: ([io,phys]A(n,n); int uplo(); [io,phys]B(n,m); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Computes the solution to a real system of linear equations A * X = B, where A is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. The diagonal pivoting method is used to factor A as A = U * D * U', if uplo = 0, or A = L * D * L', if uplo = 1, where U (or L) is a product of permutation and unit upper (lower) triangular matrices, and D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then used to solve the system of equations A * X = B. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, if info = 0, the block diagonal matrix D and the multipliers used to obtain the factor U or L from the factorization A = U*D*U' or A = L*D*L' as computed by sytrf. ipiv: Details of the interchanges and the block structure of D, as determined by sytrf. If ipiv(k) > 0, then rows and columns k and ipiv(k) were interchanged, and D(k,k) is a 1-by-1 diagonal block. If uplo = 0 and ipiv(k) = ipiv(k-1) < 0, then rows and columns k-1 and -ipiv(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If uplo = 1 and ipiv(k) = ipiv(k+1) < 0, then rows and columns k+1 and -ipiv(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. B: On entry, the N-by-NRHS right hand side matrix B. On exit, if info = 0, the N-by-NRHS solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, D(i,i) is exactly zero. The factorization has been completed, but the block diagonal matrix D is exactly singular, so the solution could not be computed. =for example # Assume $a is symmetric ;) $a = random (5,5); $a = transpose($a); $b = random(4,5); $b = transpose($b); sysv($a, 1, $b, (my $ipiv=zeroes(5)),(my $info=null)); print "The solution matrix X is :". transpose($b)."\n" unless $info; =for bad sysv ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sysv = \&PDL::sysv; =head2 sysvx =for sig Signature: ([phys]A(n,n); int uplo(); int fact(); [phys]B(n,m); [io,phys]af(n,n); int [io,phys]ipiv(n); [o,phys]X(n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); int [o,phys]info()) =for ref Uses the diagonal pivoting factorization to compute the solution to a real system of linear equations A * X = B, where A is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. Error bounds on the solution and a condition estimate are also provided. The following steps are performed: =over 3 =item 1 If fact = 0, the diagonal pivoting method is used to factor A. The form of the factorization is A = U * D * U', if uplo = 0, or A = L * D * L', if uplo = 1, where U (or L) is a product of permutation and unit upper (lower) triangular matrices, and D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. =item 2 If some D(i,i)=0, so that D is exactly singular, then the routine returns with info = i. Otherwise, the factored form of A is used to estimate the condition number of the matrix A. If the reciprocal of the condition number is less than machine precision, info = N+1 is returned as a warning, but the routine still goes on to solve for X and compute error bounds as described below. =item 3 The system of equations is solved for X using the factored form of A. =item 4 Iterative refinement is applied to improve the computed solution matrix and calculate error bounds and backward error estimates for it. =back Arguments ========= fact: Specifies whether or not the factored form of A has been supplied on entry. = 0: The matrix A will be copied to af and factored. = 1: On entry, af and ipiv contain the factored form of A. af and ipiv will not be modified. uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: The symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. af: If fact = 1, then af is an input argument and on entry contains the block diagonal matrix D and the multipliers used to obtain the factor U or L from the factorization A = U*D*U' or A = L*D*L' as computed by sytrf. If fact = 0, then af is an output argument and on exit returns the block diagonal matrix D and the multipliers used to obtain the factor U or L from the factorization A = U*D*U' or A = L*D*L'. ipiv: If fact = 1, then ipiv is an input argument and on entry contains details of the interchanges and the block structure of D, as determined by sytrf. If ipiv(k) > 0, then rows and columns k and ipiv(k) were interchanged and D(k,k) is a 1-by-1 diagonal block. If uplo = 0 and ipiv(k) = ipiv(k-1) < 0, then rows and columns k-1 and -ipiv(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If uplo = 1 and ipiv(k) = ipiv(k+1) < 0, then rows and columns k+1 and -ipiv(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. If fact = 0, then ipiv is an output argument and on exit contains details of the interchanges and the block structure of D, as determined by sytrf. B: The N-by-NRHS right hand side matrix B. X: If info = 0 or info = N+1, the N-by-NRHS solution matrix X. rcond: The estimate of the reciprocal condition number of the matrix A. If rcond is less than the machine precision (in particular, if rcond = 0), the matrix is singular to working precision. This condition is indicated by a return code of info > 0. ferr: The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), ferr(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for rcond, and is almost always a slight overestimate of the true error. berr: The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, and i is <= N: D(i,i) is exactly zero. The factorization has been completed but the factor D is exactly singular, so the solution and error bounds could not be computed. rcond = 0 is returned. = N+1: D is nonsingular, but rcond is less than machine precision, meaning that the matrix is singular to working precision. Nevertheless, the solution and error bounds are computed because there are a number of situations where the computed solution can be more accurate than the value of rcond would suggest. =for example $a= random(5,5); $b = random(10,5); $a = transpose($a); $b = transpose($b); $X = zeroes($b); $af = zeroes($a); $ipiv = zeroes(long, 5); $rcond = pdl(0); $ferr = zeroes(10); $berr = zeroes(10); $info = pdl(long, 0); # Assume $a is symmetric sysvx($a, 0, 0, $b,$af, $ipiv, $X, $rcond, $ferr, $berr,$info); print "The solution matrix X is :". transpose($X)."\n"; =for bad sysvx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sysvx = \&PDL::sysvx; =head2 posv =for sig Signature: ([io,phys]A(n,n); int uplo(); [io,phys]B(n,m); int [o,phys]info()) =for ref Computes the solution to a real system of linear equations A * X = B, where A is an N-by-N symmetric positive definite matrix and X and B are N-by-NRHS matrices. The Cholesky decomposition is used to factor A as A = U'* U, if uplo = 0, or A = L * L', if uplo = 1, where U is an upper triangular matrix and L is a lower triangular matrix. The factored form of A is then used to solve the system of equations A * X = B. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, if info = 0, the factor U or L from the Cholesky factorization A = U'*U or A = L*L'. B: On entry, the N-by-NRHS right hand side matrix B. On exit, if info = 0, the N-by-NRHS solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the leading minor of order i of A is not positive definite, so the factorization could not be completed, and the solution has not been computed. =for example # Assume $a is symmetric positive definite ;) $a = random (5,5); $a = transpose($a); $b = random(4,5); $b = transpose($b); posv($a, 1, $b, (my $info=null)); print "The solution matrix X is :". transpose($b)."\n" unless $info; =for bad posv ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *posv = \&PDL::posv; =head2 posvx =for sig Signature: ([io,phys]A(n,n); int uplo(); int fact(); [io,phys]B(n,m); [io,phys]af(n,n); int [io]equed(); [io,phys]s(n); [o,phys]X(n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); int [o,phys]info()) =for ref Uses the Cholesky factorization A = U'*U or A = L*L' to compute the solution to a real system of linear equations A * X = B, where A is an N-by-N symmetric positive definite matrix and X and B are N-by-NRHS matrices. Error bounds on the solution and a condition estimate are also provided. The following steps are performed: =over 3 =item 1 If fact = 2, real scaling factors are computed to equilibrate the system: diag(s) * A * diag(s) * inv(diag(s)) * X = diag(s) * B Whether or not the system will be equilibrated depends on the scaling of the matrix A, but if equilibration is used, A is overwritten by diag(s)*A*diag(s) and B by diag(s)*B. =item 2 If fact = 1 or 2, the Cholesky decomposition is used to factor the matrix A (after equilibration if fact = 2) as A = U'* U, if uplo = 0, or A = L * L', if uplo = 1, where U is an upper triangular matrix and L is a lower triangular matrix. =item 3 If the leading i-by-i principal minor is not positive definite, then the routine returns with info = i. Otherwise, the factored form of A is used to estimate the condition number of the matrix A. If the reciprocal of the condition number is less than machine precision, info = N+1 is returned as a warning, but the routine still goes on to solve for X and compute error bounds as described below. =item 4 The system of equations is solved for X using the factored form of A. =item 5 Iterative refinement is applied to improve the computed solution matrix and calculate error bounds and backward error estimates for it. =item 6 If equilibration was used, the matrix X is premultiplied by diag(s) so that it solves the original system before equilibration. =back Arguments ========= fact: Specifies whether or not the factored form of the matrix A is supplied on entry, and if not, whether the matrix A should be equilibrated before it is factored. = 0: On entry, af contains the factored form of A. If equed = 1, the matrix A has been equilibrated with scaling factors given by s. A and af will not be modified. = 1: The matrix A will be copied to af and factored. = 2: The matrix A will be equilibrated if necessary, then copied to af and factored. uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A, except if fact = 0 and equed = 1, then A must contain the equilibrated matrix diag(s)*A*diag(s). If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. A is not modified if fact = 0 or 1, or if fact = 2 and equed = 0 on exit. On exit, if fact = 2 and equed = 1, A is overwritten by diag(s)*A*diag(s). af: If fact = 0, then af is an input argument and on entry contains the triangular factor U or L from the Cholesky factorization A = U'*U or A = L*L', in the same storage format as A. If equed != 0, then af is the factored form of the equilibrated matrix diag(s)*A*diag(s). If fact = 1, then af is an output argument and on exit returns the triangular factor U or L from the Cholesky factorization A = U'*U or A = L*L' of the original matrix A. If fact = 2, then af is an output argument and on exit returns the triangular factor U or L from the Cholesky factorization A = U'*U or A = L*L' of the equilibrated matrix A (see the description of A for the form of the equilibrated matrix). equed: Specifies the form of equilibration that was done. = 0: No equilibration (always true if fact = 1). = 1: Equilibration was done, i.e., A has been replaced by diag(s) * A * diag(s). equed is an input argument if fact = 0; otherwise, it is an output argument. s: The scale factors for A; not accessed if equed = 0. s is an input argument if fact = 0; otherwise, s is an output argument. If fact = 0 and equed = 1, each element of s must be positive. B: On entry, the N-by-NRHS right hand side matrix B. On exit, if equed = 0, B is not modified; if equed = 1, B is overwritten by diag(s) * B. X: If info = 0 or info = N+1, the N-by-NRHS solution matrix X to the original system of equations. Note that if equed = 1, A and B are modified on exit, and the solution to the equilibrated system is inv(diag(s))*X. rcond: The estimate of the reciprocal condition number of the matrix A after equilibration (if done). If rcond is less than the machine precision (in particular, if rcond = 0), the matrix is singular to working precision. This condition is indicated by a return code of info > 0. ferr: The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), FERR(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for rcond, and is almost always a slight overestimate of the true error. berr: The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, and i is <= N: the leading minor of order i of A is not positive definite, so the factorization could not be completed, and the solution has not been computed. rcond = 0 is returned. = N+1: U is nonsingular, but rcond is less than machine precision, meaning that the matrix is singular to working precision. Nevertheless, the solution and error bounds are computed because there are a number of situations where the computed solution can be more accurate than the value of rcond would suggest. =for example $a= random(5,5); $b = random(5,5); $a = transpose($a); $b = transpose($b); # Assume $a is symmetric positive definite $rcond = pdl(0); $equed = pdl(long,0); $info = pdl(long,0); $berr = zeroes(5); $ferr = zeroes(5); $s = zeroes(5); $X = zeroes(5,5); $af = zeroes(5,5); posvx($a,0,2,$b,$af, $equed, $s, $X, $rcond, $ferr, $berr,$info); print "The solution matrix X is :". transpose($X)."\n" unless $info; =for bad posvx ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *posvx = \&PDL::posvx; =head2 gels =for sig Signature: ([io,phys]A(m,n); int trans(); [io,phys]B(p,q);int [o,phys]info()) =for ref Solves overdetermined or underdetermined real linear systems involving an M-by-N matrix A, or its transpose, using a QR or LQ factorization of A. It is assumed that A has full rank. The following options are provided: =over 3 =item 1 If trans = 0 and m >= n: find the least squares solution of an overdetermined system, i.e., solve the least squares problem minimize || B - A*X ||. =item 2 If trans = 0 and m < n: find the minimum norm solution of an underdetermined system A * X = B. =item 3 If trans = 1 and m >= n: find the minimum norm solution of an undetermined system A' * X = B. =item 4 If trans = 1 and m < n: find the least squares solution of an overdetermined system, i.e., solve the least squares problem minimize || B - A' * X ||. =back Several right hand side vectors b and solution vectors x can be handled in a single call; they are stored as the columns of the M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix X. Arguments ========= trans: = 0: the linear system involves A; = 1: the linear system involves A'. A: On entry, the M-by-N matrix A. On exit, if M >= N, A is overwritten by details of its QR factorization as returned by geqrf; if M < N, A is overwritten by details of its LQ factorization as returned by gelqf. B: On entry, the matrix B of right hand side vectors, stored columnwise; B is M-by-NRHS if trans = 0, or N-by-NRHS if trans = 1. On exit, B is overwritten by the solution vectors, stored columnwise: if trans = 0 and m >= n, rows 1 to n of B contain the least squares solution vectors; the residual sum of squares for the solution in each column is given by the sum of squares of elements N+1 to M in that column; if trans = 0 and m < n, rows 1 to N of B contain the minimum norm solution vectors; if trans = 1 and m >= n, rows 1 to M of B contain the minimum norm solution vectors; if trans = 1 and m < n, rows 1 to M of B contain the least squares solution vectors; the residual sum of squares for the solution in each column is given by the sum of squares of elements M+1 to N in that column. The leading dimension of the array B >= max(1,M,N). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a= random(7,5); # $b will contain X # TODO better example with slice $b = random(7,6); gels($a, 1, $b, ($info = null)); =for bad gels ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gels = \&PDL::gels; =head2 gelsy =for sig Signature: ([io,phys]A(m,n); [io,phys]B(p,q); [phys]rcond(); int [io,phys]jpvt(n); int [o,phys]rank();int [o,phys]info()) =for ref Computes the minimum-norm solution to a real linear least squares problem: minimize || A * X - B || using a complete orthogonal factorization of A. A is an M-by-N matrix which may be rank-deficient. Several right hand side vectors b and solution vectors x can be handled in a single call; they are stored as the columns of the M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix X. The routine first computes a QR factorization with column pivoting: A * P = Q * [ R11 R12 ] [ 0 R22 ] with R11 defined as the largest leading submatrix whose estimated condition number is less than 1/rcond. The order of R11, rank, is the effective rank of A. Then, R22 is considered to be negligible, and R12 is annihilated by orthogonal transformations from the right, arriving at the complete orthogonal factorization: A * P = Q * [ T11 0 ] * Z [ 0 0 ] The minimum-norm solution is then X = P * Z' [ inv(T11)*Q1'*B ] [ 0 ] where Q1 consists of the first rank columns of Q. Arguments ========= A: On entry, the M-by-N matrix A. On exit, A has been overwritten by details of its complete orthogonal factorization. B: On entry, the M-by-NRHS right hand side matrix B. On exit, the N-by-NRHS solution matrix X. The leading dimension of the array B >= max(1,M,N). jpvt: On entry, if jpvt(i) != 0, the i-th column of A is permuted to the front of AP, otherwise column i is a free column. On exit, if jpvt(i) = k, then the i-th column of AP was the k-th column of A. rcond: rcond is used to determine the effective rank of A, which is defined as the order of the largest leading triangular submatrix R11 in the QR factorization with pivoting of A, whose estimated condition number < 1/rcond. rank: The effective rank of A, i.e., the order of the submatrix R11. This is the same as the order of the submatrix T11 in the complete orthogonal factorization of A. info: = 0: successful exit < 0: If info = -i, the i-th argument had an illegal value. =for example $a= random(7,5); # $b will contain X # TODO better example with slice $b = random(7,6); $jpvt = zeroes(long, 5); $eps = lamch(0); #Threshold for rank estimation $rcond = sqrt($eps) - (sqrt($eps) - $eps) / 2; gelsy($a, $b, $rcond, $jpvt,($rank=null),($info = null)); =for bad gelsy ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gelsy = \&PDL::gelsy; =head2 gelss =for sig Signature: ([io,phys]A(m,n); [io,phys]B(p,q); [phys]rcond(); [o,phys]s(r); int [o,phys]rank();int [o,phys]info()) =for ref Computes the minimum norm solution to a real linear least squares problem: Minimize 2-norm(| b - A*x |). using the singular value decomposition (SVD) of A. A is an M-by-N matrix which may be rank-deficient. Several right hand side vectors b and solution vectors x can be handled in a single call; they are stored as the columns of the M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix X. The effective rank of A is determined by treating as zero those singular values which are less than rcond times the largest singular value. Arguments ========= A: On entry, the M-by-N matrix A. On exit, the first min(m,n) rows of A are overwritten with its right singular vectors, stored rowwise. B: On entry, the M-by-NRHS right hand side matrix B. On exit, B is overwritten by the N-by-NRHS solution matrix X. If m >= n and rank = n, the residual sum-of-squares for the solution in the i-th column is given by the sum of squares of elements n+1:m in that column. The leading dimension of the array B >= max(1,M,N). s: The singular values of A in decreasing order. The condition number of A in the 2-norm = s(1)/s(min(m,n)). rcond: rcond is used to determine the effective rank of A. Singular values s(i) <= rcond*s(1) are treated as zero. If rcond < 0, machine precision is used instead. rank: The effective rank of A, i.e., the number of singular values which are greater than rcond*s(1). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: the algorithm for computing the SVD failed to converge; if info = i, i off-diagonal elements of an intermediate bidiagonal form did not converge to zero. =for example $a= random(7,5); # $b will contain X # TODO better example with slice $b = random(7,6); $eps = lamch(0); $s =zeroes(5); #Threshold for rank estimation $rcond = sqrt($eps) - (sqrt($eps) - $eps) / 2; gelss($a, $b, $rcond, $s, ($rank=null),($info = null)); =for bad gelss ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gelss = \&PDL::gelss; =head2 gelsd =for sig Signature: ([io,phys]A(m,n); [io,phys]B(p,q); [phys]rcond(); [o,phys]s(r); int [o,phys]rank();int [o,phys]info()) =for ref Computes the minimum-norm solution to a real linear least squares problem: minimize 2-norm(| b - A*x |) using the singular value decomposition (SVD) of A. A is an M-by-N matrix which may be rank-deficient. Several right hand side vectors b and solution vectors x can be handled in a single call; they are stored as the columns of the M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix X. The problem is solved in three steps: =over 3 =item 1 Reduce the coefficient matrix A to bidiagonal form with Householder transformations, reducing the original problem into a "bidiagonal least squares problem" (BLS) =item 2 Solve the BLS using a divide and conquer approach. =item 3 Apply back all the Householder tranformations to solve the original least squares problem. =back The effective rank of A is determined by treating as zero those singular values which are less than rcond times the largest singular value. The divide and conquer algorithm makes very mild assumptions about floating point arithmetic. It will work on machines with a guard digit in add/subtract, or on those binary machines without guard digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. It could conceivably fail on hexadecimal or decimal machines without guard digits, but we know of none. Arguments ========= A: On entry, the M-by-N matrix A. On exit, A has been destroyed. B: On entry, the M-by-NRHS right hand side matrix B. On exit, B is overwritten by the N-by-NRHS solution matrix X. If m >= n and rank = n, the residual sum-of-squares for the solution in the i-th column is given by the sum of squares of elements n+1:m in that column. The leading dimension of the array B >= max(1,M,N). s: The singular values of A in decreasing order. The condition number of A in the 2-norm = s(1)/s(min(m,n)). rcond: rcond is used to determine the effective rank of A. Singular values s(i) <= rcond*s(1) are treated as zero. If rcond < 0, machine precision is used instead. rank: The effective rank of A, i.e., the number of singular values which are greater than rcond*s(1). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: the algorithm for computing the SVD failed to converge; if info = i, i off-diagonal elements of an intermediate bidiagonal form did not converge to zero. =for example $a= random(7,5); # $b will contain X # TODO better example with slice $b = random(7,6); $eps = lamch(0); $s =zeroes(5); #Threshold for rank estimation $rcond = sqrt($eps) - (sqrt($eps) - $eps) / 2; gelsd($a, $b, $rcond, $s, ($rank=null),($info = null)); =for bad gelsd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gelsd = \&PDL::gelsd; =head2 gglse =for sig Signature: ([phys]A(m,n); [phys]B(p,n);[io,phys]c(m);[phys]d(p);[o,phys]x(n);int [o,phys]info()) =for ref Solves the linear equality-constrained least squares (LSE) problem: minimize || c - A*x ||_2 subject to B*x = d where A is an M-by-N matrix, B is a P-by-N matrix, c is a given M-vector, and d is a given P-vector. It is assumed that P <= N <= M+P, and rank(B) = P and rank( ( A ) ) = N. ( ( B ) ) These conditions ensure that the LSE problem has a unique solution, which is obtained using a GRQ factorization of the matrices B and A. Arguments ========= A: On entry, the M-by-N matrix A. On exit, A is destroyed. B: On entry, the P-by-N matrix B. On exit, B is destroyed. c: On entry, c contains the right hand side vector for the least squares part of the LSE problem. On exit, the residual sum of squares for the solution is given by the sum of squares of elements N-P+1 to M of vector c. d: On entry, d contains the right hand side vector for the constrained equation. On exit, d is destroyed. x: On exit, x is the solution of the LSE problem. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random(7,5); $b = random(4,5); $c = random(7); $d = random(4); $x = zeroes(5); gglse($a, $b, $c, $d, $x, ($info=null)); =for bad gglse ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gglse = \&PDL::gglse; =head2 ggglm =for sig Signature: ([phys]A(n,m); [phys]B(n,p);[phys]d(n);[o,phys]x(m);[o,phys]y(p);int [o,phys]info()) =for ref Solves a general Gauss-Markov linear model (GLM) problem: minimize || y ||_2 subject to d = A*x + B*y x where A is an N-by-M matrix, B is an N-by-P matrix, and d is a given N-vector. It is assumed that M <= N <= M+P, and rank(A) = M and rank( A B ) = N. Under these assumptions, the constrained equation is always consistent, and there is a unique solution x and a minimal 2-norm solution y, which is obtained using a generalized QR factorization of A and B. In particular, if matrix B is square nonsingular, then the problem GLM is equivalent to the following weighted linear least squares problem minimize || inv(B)*(d-A*x) ||_2 x where inv(B) denotes the inverse of B. Arguments ========= A: On entry, the N-by-M matrix A. On exit, A is destroyed. B: On entry, the N-by-P matrix B. On exit, B is destroyed. d: On entry, d is the left hand side of the GLM equation. On exit, d is destroyed. x: y: On exit, x and y are the solutions of the GLM problem. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random(7,5); $b = random(7,4); $d = random(7); $x = zeroes(5); $y = zeroes(4); ggglm($a, $b, $d, $x, $y,($info=null)); =for bad ggglm ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ggglm = \&PDL::ggglm; =head2 getrf =for sig Signature: ([io,phys]A(m,n); int [o,phys]ipiv(p); int [o,phys]info()) =for ref Computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges. The factorization has the form A = P * L * U where P is a permutation matrix, L is lower triangular with unit diagonal elements (lower trapezoidal if m > n), and U is upper triangular (upper trapezoidal if m < n). This is the right-looking Level 3 BLAS version of the algorithm. Arguments ========= A: On entry, the M-by-N matrix to be factored. On exit, the factors L and U from the factorization A = P*L*U; the unit diagonal elements of L are not stored. ipiv: The pivot indices; for 1 <= i <= min(M,N), row i of the matrix was interchanged with row ipiv(i). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, U(i,i) is exactly zero. The factorization has been completed, but the factor U is exactly singular, and division by zero will occur if it is used to solve a system of equations. =for example $a = random (float, 100,50); $ipiv = zeroes(long, 50); $info = null; getrf($a, $ipiv, $info); =for bad getrf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *getrf = \&PDL::getrf; =head2 getf2 =for sig Signature: ([io,phys]A(m,n); int [o,phys]ipiv(p); int [o,phys]info()) =for ref Computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges. The factorization has the form A = P * L * U where P is a permutation matrix, L is lower triangular with unit diagonal elements (lower trapezoidal if m > n), and U is upper triangular (upper trapezoidal if m < n). This is the right-looking Level 2 BLAS version of the algorithm. Arguments ========= A: On entry, the M-by-N matrix to be factored. On exit, the factors L and U from the factorization A = P*L*U; the unit diagonal elements of L are not stored. ipiv: The pivot indices; for 1 <= i <= min(M,N), row i of the matrix was interchanged with row ipiv(i). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, U(i,i) is exactly zero. The factorization has been completed, but the factor U is exactly singular, and division by zero will occur if it is used to solve a system of equations. =for example $a = random (float, 100,50); $ipiv = zeroes(long, 50); $info = null; getf2($a, $ipiv, $info); =for bad getf2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *getf2 = \&PDL::getf2; =head2 sytrf =for sig Signature: ([io,phys]A(n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Computes the factorization of a real symmetric matrix A using the Bunch-Kaufman diagonal pivoting method. The form of the factorization is A = U*D*U' or A = L*D*L' where U (or L) is a product of permutation and unit upper (lower) triangular matrices, and D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. This is the blocked version of the algorithm, calling Level 3 BLAS. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, the block diagonal matrix D and the multipliers used to obtain the factor U or L (see below for further details). ipiv: Details of the interchanges and the block structure of D. If ipiv(k) > 0, then rows and columns k and ipiv(k) were interchanged and D(k,k) is a 1-by-1 diagonal block. If uplo = 0 and ipiv(k) = ipiv(k-1) < 0, then rows and columns k-1 and -ipiv(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If uplo = 1 and ipiv(k) = ipiv(k+1) < 0, then rows and columns k+1 and -ipiv(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, D(i,i) is exactly zero. The factorization has been completed, but the block diagonal matrix D is exactly singular, and division by zero will occur if it is used to solve a system of equations. Further Details =============== If uplo = 0, then A = U*D*U', where U = P(n)*U(n)* ... *P(k)U(k)* ..., i.e., U is a product of terms P(k)*U(k), where k decreases from n to 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as defined by ipiv(k), and U(k) is a unit upper triangular matrix, such that if the diagonal block D(k) is of order s (s = 1 or 2), then ( I v 0 ) k-s U(k) = ( 0 I 0 ) s ( 0 0 I ) n-k k-s s n-k If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), and A(k,k), and v overwrites A(1:k-2,k-1:k). If uplo = 1, then A = L*D*L', where L = P(1)*L(1)* ... *P(k)*L(k)* ..., i.e., L is a product of terms P(k)*L(k), where k increases from 1 to n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as defined by ipiv(k), and L(k) is a unit lower triangular matrix, such that if the diagonal block D(k) is of order s (s = 1 or 2), then ( I 0 0 ) k-1 L(k) = ( 0 I 0 ) s ( 0 v I ) n-k-s+1 k-1 s n-k-s+1 If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). =for example $a = random(100,100); $ipiv = zeroes(100); $info = null; # Assume $a is symmetric sytrf($a, 0, $ipiv, $info); =for bad sytrf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sytrf = \&PDL::sytrf; =head2 sytf2 =for sig Signature: ([io,phys]A(n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()) =for ref Computes the factorization of a real symmetric matrix A using the Bunch-Kaufman diagonal pivoting method. The form of the factorization is A = U*D*U' or A = L*D*L' where U (or L) is a product of permutation and unit upper (lower) triangular matrices, and D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. This is the unblocked version of the algorithm, calling Level 2 BLAS. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, the block diagonal matrix D and the multipliers used to obtain the factor U or L (see below for further details). ipiv: Details of the interchanges and the block structure of D. If ipiv(k) > 0, then rows and columns k and ipiv(k) were interchanged and D(k,k) is a 1-by-1 diagonal block. If uplo = 0 and ipiv(k) = ipiv(k-1) < 0, then rows and columns k-1 and -ipiv(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If uplo = 1 and ipiv(k) = ipiv(k+1) < 0, then rows and columns k+1 and -ipiv(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, D(i,i) is exactly zero. The factorization has been completed, but the block diagonal matrix D is exactly singular, and division by zero will occur if it is used to solve a system of equations. For further details see sytrf =for example $a = random(100,100); $ipiv = zeroes(100); $info = null; # Assume $a is symmetric sytf2($a, 0, $ipiv, $info); =for bad sytf2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sytf2 = \&PDL::sytf2; =head2 potrf =for sig Signature: ([io,phys]A(n,n); int uplo(); int [o,phys]info()) =for ref Computes the Cholesky factorization of a real symmetric positive definite matrix A. The factorization has the form A = U' * U, if uplo = 0, or A = L * L', if uplo = 1, where U is an upper triangular matrix and L is lower triangular. This is the block version of the algorithm, calling Level 3 BLAS. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, if info = 0, the factor U or L from the Cholesky factorization A = U'*U or A = L*L'. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the leading minor of order i is not positive definite, and the factorization could not be completed. =for example $a = random(100,100); # Assume $a is symmetric positive definite potrf($a, 0, ($info = null)); =for bad potrf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *potrf = \&PDL::potrf; =head2 potf2 =for sig Signature: ([io,phys]A(n,n); int uplo(); int [o,phys]info()) =for ref Computes the Cholesky factorization of a real symmetric positive definite matrix A. The factorization has the form A = U' * U, if uplo = 0, or A = L * L', if uplo = 1, where U is an upper triangular matrix and L is lower triangular. This is the unblocked version of the algorithm, calling Level 2 BLAS. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, if info = 0, the factor U or L from the Cholesky factorization A = U'*U or A = L*L'. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the leading minor of order i is not positive definite, and the factorization could not be completed. =for example $a = random(100,100); # Assume $a is symmetric positive definite potf2($a, 0, ($info = null)); =for bad potf2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *potf2 = \&PDL::potf2; =head2 getri =for sig Signature: ([io,phys]A(n,n); int [phys]ipiv(n); int [o,phys]info()) =for ref Computes the inverse of a matrix using the LU factorization computed by C. This method inverts U and then computes inv(A) by solving the system inv(A)*L = inv(U) for inv(A). Arguments ========= A: On entry, the factors L and U from the factorization A = P*L*U as computed by getrf. On exit, if info = 0, the inverse of the original matrix A. ipiv: The pivot indices from getrf; for 1<=i<=N, row i of the matrix was interchanged with row ipiv(i). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, U(i,i) is exactly zero; the matrix is singular and its inverse could not be computed. =for example $a = random (float, 100, 100); $ipiv = zeroes(long, 100); $info = null; getrf($a, $ipiv, $info); if ($info == 0){ getri($a, $ipiv, $info); } print "Inverse of \$a is :\n $a" unless $info; =for bad getri ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *getri = \&PDL::getri; =head2 sytri =for sig Signature: ([io,phys]A(n,n); int uplo(); int [phys]ipiv(n); int [o,phys]info()) =for ref Computes the inverse of a real symmetric indefinite matrix A using the factorization A = U*D*U' or A = L*D*L' computed by C. Arguments ========= uplo: Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 0: Upper triangular, form is A = U*D*U'; = 1: Lower triangular, form is A = L*D*L'. A: On entry, the block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by sytrf. On exit, if info = 0, the (symmetric) inverse of the original matrix. If uplo = 0, the upper triangular part of the inverse is formed and the part of A below the diagonal is not referenced; if uplo = 1 the lower triangular part of the inverse is formed and the part of A above the diagonal is not referenced. ipiv: Details of the interchanges and the block structure of D as determined by sytrf. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, D(i,i) = 0; the matrix is singular and its inverse could not be computed. =for example $a = random (float, 100, 100); # assume $a is symmetric $ipiv = zeroes(long, 100); sytrf($a, 0, $ipiv, ($info=null)); if ($info == 0){ sytri($a, 0, $ipiv, $info); } print "Inverse of \$a is :\n $a" unless $info; =for bad sytri ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sytri = \&PDL::sytri; =head2 potri =for sig Signature: ([io,phys]A(n,n); int uplo(); int [o,phys]info()) =for ref Computes the inverse of a real symmetric positive definite matrix A using the Cholesky factorization A = U'*U or A = L*L' computed by C. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the triangular factor U or L from the Cholesky factorization A = U'*U or A = L*L', as computed by potrf. On exit, the upper or lower triangle of the (symmetric) inverse of A, overwriting the input factor U or L. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the (i,i) element of the factor U or L is zero, and the inverse could not be computed. =for example $a = random (float, 100, 100); # Assume $a is symmetric positive definite potrf($a, 0, ($info = null)); if ($info == 0){ # Hum... is it positive definite???? potri($a, 0,$info); } print "Inverse of \$a is :\n $a" unless $info; =for bad potri ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *potri = \&PDL::potri; =head2 trtri =for sig Signature: ([io,phys]A(n,n); int uplo(); int diag(); int [o,phys]info()) =for ref Computes the inverse of a real upper or lower triangular matrix A. This is the Level 3 BLAS version of the algorithm. Arguments ========= uplo: = 0: A is upper triangular; = 1: A is lower triangular. diag: = 0: A is non-unit triangular; = 1: A is unit triangular. A: On entry, the triangular matrix A. If uplo = 0, the leading N-by-N upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If diag = 1, the diagonal elements of A are also not referenced and are assumed to be 1. On exit, the (triangular) inverse of the original matrix, in the same storage format. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, A(i,i) is exactly zero. The triangular matrix is singular and its inverse can not be computed. =for example $a = random (float, 100, 100); # assume $a is upper triangular trtri($a, 1, ($info=null)); print "Inverse of \$a is :\n transpose($a)" unless $info; =for bad trtri ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *trtri = \&PDL::trtri; =head2 trti2 =for sig Signature: ([io,phys]A(n,n); int uplo(); int diag(); int [o,phys]info()) =for ref Computes the inverse of a real upper or lower triangular matrix A. This is the Level 2 BLAS version of the algorithm. Arguments ========= uplo: = 0: A is upper triangular; = 1: A is lower triangular. diag: = 0: A is non-unit triangular; = 1: A is unit triangular. A: On entry, the triangular matrix A. If uplo = 0, the leading N-by-N upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If diag = 1, the diagonal elements of A are also not referenced and are assumed to be 1. On exit, the (triangular) inverse of the original matrix, in the same storage format. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 100); # assume $a is upper triangular trtri2($a, 1, ($info=null)); print "Inverse of \$a is :\n transpose($a)" unless $info; =for bad trti2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *trti2 = \&PDL::trti2; =head2 getrs =for sig Signature: ([phys]A(n,n); int trans(); [io,phys]B(n,m); int [phys]ipiv(n); int [o,phys]info()) =for ref 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. Arguments ========= trans: Specifies the form of the system of equations: = 0: A * X = B (No transpose) = 1: A'* X = B (Transpose) A: The factors L and U from the factorization A = P*L*U as computed by getrf. ipiv: The pivot indices from getrf; for 1<=i<=N, row i of the matrix was interchanged with row ipiv(i). B: On entry, the right hand side matrix B. On exit, the solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 100); $ipiv = zeroes(long, 100); $b = random(100,50); getrf($a, $ipiv, ($info=null)); if ($info == 0){ getrs($a, 0, $b, $ipiv, $info); } print "X is :\n $b" unless $info; =for bad getrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *getrs = \&PDL::getrs; =head2 sytrs =for sig Signature: ([phys]A(n,n); int uplo();[io,phys]B(n,m); int [phys]ipiv(n); int [o,phys]info()) =for ref Solves a system of linear equations A*X = B with a real symmetric matrix A using the factorization A = U*D*U' or A = L*D*L' computed by C. Arguments ========= uplo: Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 0: Upper triangular, form is A = U*D*U'; = 1: Lower triangular, form is A = L*D*L'. A: The block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by sytrf. ipiv: Details of the interchanges and the block structure of D as determined by sytrf. B: On entry, the right hand side matrix B. On exit, the solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 100); $b = random(50,100); $a = transpose($a); $b = transpose($b); # Assume $a is symmetric sytrf($a, 0, ($ipiv=zeroes(100)), ($info=null)); if ($info == 0){ sytrs($a, 0, $b, $ipiv, $info); } print("X is :\n".transpose($b))unless $info; =for bad sytrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sytrs = \&PDL::sytrs; =head2 potrs =for sig Signature: ([phys]A(n,n); int uplo(); [io,phys]B(n,m); int [o,phys]info()) =for ref Solves a system of linear equations A*X = B with a symmetric positive definite matrix A using the Cholesky factorization A = U'*U or A = L*L' computed by C. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: The triangular factor U or L from the Cholesky factorization A = U'*U or A = L*L', as computed by potrf. B: On entry, the right hand side matrix B. On exit, the solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 100); $b = random(50,100); $a = transpose($a); $b = transpose($b); # Assume $a is symmetric positive definite potrf($a, 0, ($info=null)); if ($info == 0){ potrs($a, 0, $b, $info); } print("X is :\n".transpose($b))unless $info; =for bad potrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *potrs = \&PDL::potrs; =head2 trtrs =for sig Signature: ([phys]A(n,n); int uplo(); int trans(); int diag();[io,phys]B(n,m); int [o,phys]info()) =for ref Solves a triangular system of the form A * X = B or A' * X = B, where A is a triangular matrix of order N, and B is an N-by-NRHS matrix. A check is made to verify that A is nonsingular. Arguments ========= uplo: = 0: A is upper triangular; = 1: A is lower triangular. trans: Specifies the form of the system of equations: = 0: A * X = B (No transpose) = 1: A**T * X = B (Transpose) diag: = 0: A is non-unit triangular; = 1: A is unit triangular. A: The triangular matrix A. If uplo = 0, the leading N-by-N upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If diag = 1, the diagonal elements of A are also not referenced and are assumed to be 1. B: On entry, the right hand side matrix B. On exit, if info = 0, the solution matrix X. info = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the i-th diagonal element of A is zero, indicating that the matrix is singular and the solutions X have not been computed. =for example # Assume $a is upper triangular $a = random (float, 100, 100); $b = random(50,100); $a = transpose($a); $b = transpose($b); $info = null; trtrs($a, 0, 0, 0, $b, $info); print("X is :\n".transpose($b))unless $info; =for bad trtrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *trtrs = \&PDL::trtrs; =head2 latrs =for sig Signature: ([phys]A(n,n); int uplo(); int trans(); int diag(); int normin();[io,phys]x(n); [o,phys]scale();[io,phys]cnorm(n);int [o,phys]info()) =for ref Solves one of the triangular systems A *x = s*b or A'*x = s*b with scaling to prevent overflow. Here A is an upper or lower triangular matrix, A' denotes the transpose of A, x and b are n-element vectors, and s is a scaling factor, usually less than or equal to 1, chosen so that the components of x will be less than the overflow threshold. If the unscaled problem will not cause overflow, the Level 2 BLAS routine C is called. If the matrix A is singular (A(j,j) = 0 for some j), then s is set to 0 and a non-trivial solution to A*x = 0 is returned. Further Details ======= ======= A rough bound on x is computed; if that is less than overflow, trsv is called, otherwise, specific code is used which checks for possible overflow or divide-by-zero at every operation. A columnwise scheme is used for solving A*x = b. The basic algorithm if A is lower triangular is x[1:n] := b[1:n] for j = 1, ..., n x(j) := x(j) / A(j,j) x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] end Define bounds on the components of x after j iterations of the loop: M(j) = bound on x[1:j] G(j) = bound on x[j+1:n] Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. Then for iteration j+1 we have M(j+1) <= G(j) / | A(j+1,j+1) | G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | <= G(j) ( 1 + cnorm(j+1) / | A(j+1,j+1) | ) where cnorm(j+1) is greater than or equal to the infinity-norm of column j+1 of A, not counting the diagonal. Hence G(j) <= G(0) product ( 1 + cnorm(i) / | A(i,i) | ) 1<=i<=j and |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + cnorm(i) / |A(i,i)| ) 1<=i< j Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the reciprocal of the largest M(j), j=1,..,n, is larger than max(underflow, 1/overflow). The bound on x(j) is also used to determine when a step in the columnwise method can be performed without fear of overflow. If the computed bound is greater than a large constant, x is scaled to prevent overflow, but if the bound overflows, x is set to 0, x(j) to 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. Similarly, a row-wise scheme is used to solve A'*x = b. The basic algorithm for A upper triangular is for j = 1, ..., n x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) end We simultaneously compute two bounds G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j M(j) = bound on x(i), 1<=i<=j The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. Then the bound on x(j) is M(j) <= M(j-1) * ( 1 + cnorm(j) ) / | A(j,j) | <= M(0) * product ( ( 1 + cnorm(i) ) / |A(i,i)| ) 1<=i<=j and we can safely call trsv if 1/M(n) and 1/G(n) are both greater than max(underflow, 1/overflow). Arguments ========= uplo: Specifies whether the matrix A is upper or lower triangular. = 0: Upper triangular = 1: Lower triangular trans: Specifies the operation applied to A. = 0: Solve A * x = s*b (No transpose) = 1: Solve A'* x = s*b (Transpose) diag: Specifies whether or not the matrix A is unit triangular. = 0: Non-unit triangular = 1: Unit triangular normin: Specifies whether cnorm has been set or not. = 1: cnorm contains the column norms on entry = 0: cnorm is not set on entry. On exit, the norms will be computed and stored in cnorm. A: The triangular matrix A. If uplo = 0, the leading n by n upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading n by n lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If diag = 1, the diagonal elements of A are also not referenced and are assumed to be 1. x: On entry, the right hand side b of the triangular system. On exit, x is overwritten by the solution vector x. scale: The scaling factor s for the triangular system A * x = s*b or A'* x = s*b. If scale = 0, the matrix A is singular or badly scaled, and the vector x is an exact or approximate solution to A*x = 0. cnorm: If normin = 0, cnorm is an output argument and cnorm(j) returns the 1-norm of the offdiagonal part of the j-th column of A. If normin = 1, cnorm is an input argument and cnorm(j) contains the norm of the off-diagonal part of the j-th column of A. If trans = 0, cnorm(j) must be greater than or equal to the infinity-norm, and if trans = 1, cnorm(j) must be greater than or equal to the 1-norm. info: = 0: successful exit < 0: if info = -k, the k-th argument had an illegal value =for example # Assume $a is upper triangular $a = random (float, 100, 100); $b = random(100); $a = transpose($a); $info = null; $scale= null; $cnorm = zeroes(100); latrs($a, 0, 0, 0, 0,$b, $scale, $cnorm,$info); =for bad latrs ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *latrs = \&PDL::latrs; =head2 gecon =for sig Signature: ([phys]A(n,n); int norm(); [phys]anorm(); [o,phys]rcond();int [o,phys]info()) =for ref Estimates the reciprocal of the condition number of a general real matrix A, in either the 1-norm or the infinity-norm, using the LU factorization computed by C. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as rcond = 1 / ( norm(A) * norm(inv(A)) ). Arguments ========= norm: Specifies whether the 1-norm condition number or the infinity-norm condition number is required: = 0: Infinity-norm. = 1: 1-norm; A: The factors L and U from the factorization A = P*L*U as computed by getrf. anorm: If norm = 0, the infinity-norm of the original matrix A. If norm = 1, the 1-norm of the original matrix A. rcond: The reciprocal of the condition number of the matrix A, computed as rcond = 1/(norm(A) * norm(inv(A))). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 100); $anorm = $a->lange(1); $ipiv = zeroes(long, 100); $info = null; getrf($a, $ipiv, $info); ($rcond, $info) = gecon($a, 1, $anorm) unless $info != 0; =for bad gecon ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gecon = \&PDL::gecon; =head2 sycon =for sig Signature: ([phys]A(n,n); int uplo(); int ipiv(n); [phys]anorm(); [o,phys]rcond();int [o,phys]info()) =for ref Estimates the reciprocal of the condition number (in the 1-norm) of a real symmetric matrix A using the factorization A = U*D*U' or A = L*D*L' computed by C. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as rcond = 1 / (anorm * norm(inv(A))). Arguments ========= uplo: Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 0: Upper triangular, form is A = U*D*U'; = 1: Lower triangular, form is A = L*D*L'. A: The block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by sytrf. ipiv: Details of the interchanges and the block structure of D as determined by sytrf. anorm: The 1-norm of the original matrix A. rcond: The reciprocal of the condition number of the matrix A, computed as rcond = 1/(anorm * aimvnm), where ainvnm is an estimate of the 1-norm of inv(A) computed in this routine. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. =for example # Assume $a is symmetric $a = random (float, 100, 100); $anorm = $a->lansy(1,1); $ipiv = zeroes(long, 100); $info = null; sytrf($a, 1,$ipiv, $info); ($rcond, $info) = sycon($a, 1, $anorm) unless $info != 0; =for bad sycon ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sycon = \&PDL::sycon; =head2 pocon =for sig Signature: ([phys]A(n,n); int uplo(); [phys]anorm(); [o,phys]rcond();int [o,phys]info()) =for ref Estimates the reciprocal of the condition number (in the 1-norm) of a real symmetric positive definite matrix using the Cholesky factorization A = U'*U or A = L*L' computed by C. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as rcond = 1 / (anorm * norm(inv(A))). Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: The triangular factor U or L from the Cholesky factorization A = U'*U or A = L*L', as computed by potrf. anorm: The 1-norm of the matrix A. rcond: The reciprocal of the condition number of the matrix A, computed as rcond = 1/(anorm * ainvnm), where ainvnm is an estimate of the 1-norm of inv(A) computed in this routine. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example # Assume $a is symmetric positive definite $a = random (float, 100, 100); $anorm = $a->lansy(1,1); $info = null; potrf($a, 0, $info); ($rcond, $info) = pocon($a, 1, $anorm) unless $info != 0; =for bad pocon ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *pocon = \&PDL::pocon; =head2 trcon =for sig Signature: ([phys]A(n,n); int norm();int uplo();int diag(); [o,phys]rcond();int [o,phys]info()) =for ref Estimates the reciprocal of the condition number of a triangular matrix A, in either the 1-norm or the infinity-norm. The norm of A is computed and an estimate is obtained for norm(inv(A)), then the reciprocal of the condition number is computed as rcond = 1 / ( norm(A) * norm(inv(A)) ). Arguments ========= norm: Specifies whether the 1-norm condition number or the infinity-norm condition number is required: = 0: Infinity-norm. = 1: 1-norm; uplo: = 0: A is upper triangular; = 1: A is lower triangular. diag: = 0: A is non-unit triangular; = 1: A is unit triangular. A: The triangular matrix A. If uplo = 0, the leading N-by-N upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If diag = 1, the diagonal elements of A are also not referenced and are assumed to be 1. rcond: The reciprocal of the condition number of the matrix A, computed as rcond = 1/(norm(A) * norm(inv(A))). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example # Assume $a is upper triangular $a = random (float, 100, 100); $info = null; ($rcond, $info) = trcon($a, 1, 1, 0) unless $info != 0; =for bad trcon ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *trcon = \&PDL::trcon; =head2 geqp3 =for sig Signature: ([io,phys]A(m,n); int [io,phys]jpvt(n); [o,phys]tau(k); int [o,phys]info()) =for ref geqp3 computes a QR factorization using Level 3 BLAS with column pivoting of a matrix A: A*P = Q*R The matrix Q is represented as a product of elementary reflectors Q = H(1) H(2) . . . H(k), where k = min(m,n). Each H(i) has the form H(i) = I - tau * v * v' where tau is a real/complex scalar, and v is a real/complex vector with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), and tau in tau(i). Arguments ========= A: On entry, the M-by-N matrix A. On exit, the upper triangle of the array contains the min(M,N)-by-N upper trapezoidal matrix R; the elements below the diagonal, together with the array tau, represent the orthogonal matrix Q as a product of min(M,N) elementary reflectors. jpvt: On entry, if jpvt(J)!=0, the J-th column of A is permuted to the front of A*P (a leading column); if jpvt(J)=0, the J-th column of A is a free column. On exit, if jpvt(J)=K, then the J-th column of A*P was the the K-th column of A. tau: The scalar factors of the elementary reflectors. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); $jpvt = zeroes(long, 50); geqp3($a, $jpvt, $tau, $info); =for bad geqp3 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *geqp3 = \&PDL::geqp3; =head2 geqrf =for sig Signature: ([io,phys]A(m,n); [o,phys]tau(k); int [o,phys]info()) =for ref geqrf computes a QR factorization of a matrix A: A = Q * R The matrix Q is represented as a product of elementary reflectors Q = H(1) H(2) . . . H(k), where k = min(m,n). Each H(i) has the form H(i) = I - tau * v * v' where tau is a real/complex scalar, and v is a real/complex vector with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), and tau in tau(i). Arguments ========= A: On exit, the elements on and above the diagonal of the array contain the min(M,N)-by-N upper trapezoidal matrix R (R is upper triangular if m >= n); the elements below the diagonal, with the array TAU, represent the orthogonal matrix Q as a product of min(m,n) elementary reflectors. tau: The scalar factors of the elementary reflectors. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); geqrf($a, $tau, $info); =for bad geqrf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *geqrf = \&PDL::geqrf; =head2 orgqr =for sig Signature: ([io,phys]A(m,n); [phys]tau(k); int [o,phys]info()) =for ref Generates an M-by-N real matrix Q with orthonormal columns, which is defined as the first N columns of a product of K elementary reflectors of order M Q = H(1) H(2) . . . H(k) as returned by geqrf or geqp3. Arguments ========= A: On entry, the i-th column must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by geqrf or geqp3 in the first k columns of its array argument A. On exit, the M-by-N matrix Q. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by geqrf or geqp3. info: = 0: successful exit < 0: if info = -i, the i-th argument has an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); geqrf($a, $tau, $info); orgqr($a, $tau, $info) unless $info != 0; =for bad orgqr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *orgqr = \&PDL::orgqr; =head2 ormqr =for sig Signature: ([phys]A(p,k); int side(); int trans(); [phys]tau(k); [io,phys]C(m,n);int [o,phys]info()) =for ref Overwrites the general real M-by-N matrix C with side = 0 side = 1 trans = 0: Q * C C * Q trans = 1: Q' * C C * Q' where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(1) H(2) . . . H(k) as returned by geqrf or geqp3. Q is of order M if C = 0 and of order N if C = 1. Arguments ========= side: = 0: apply Q or Q' from the Left; = 1: apply Q or Q' from the Right. trans: = 0: No transpose, apply Q; = 1: Transpose, apply Q'. A: The i-th column must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by geqrf or geqp3 in the first k columns of its array argument A. A is modified by the routine but restored on exit. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by geqrf or geqp3. C: On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $a = transpose($a); $info = null; $tau = zeroes(float, 50); geqrf($a, $tau, $info); $c = random(70,50); # $c will contain the result $c->reshape(70,100); $c = transpose($c); ormqr($a, $tau, $c, $info); =for bad ormqr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ormqr = \&PDL::ormqr; =head2 gelqf =for sig Signature: ([io,phys]A(m,n); [o,phys]tau(k); int [o,phys]info()) =for ref Computes an LQ factorization of a real M-by-N matrix A: A = L * Q. The matrix Q is represented as a product of elementary reflectors Q = H(k) . . . H(2) H(1), where k = min(m,n). Each H(i) has the form H(i) = I - tau * v * v' where tau is a real scalar, and v is a real vector with v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), and tau in tau(i). Arguments ========= A: On entry, the M-by-N matrix A. On exit, the elements on and below the diagonal of the array contain the m-by-min(m,n) lower trapezoidal matrix L (L is lower triangular if m <= n); the elements above the diagonal, with the array tau, represent the orthogonal matrix Q as a product of elementary reflectors. tau: The scalar factors of the elementary reflectors. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); gelqf($a, $tau, $info); =for bad gelqf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gelqf = \&PDL::gelqf; =head2 orglq =for sig Signature: ([io,phys]A(m,n); [phys]tau(k); int [o,phys]info()) =for ref Generates an M-by-N real matrix Q with orthonormal rows, which is defined as the first M rows of a product of K elementary reflectors of order N Q = H(k) . . . H(2) H(1) as returned by gelqf. Arguments ========= A: On entry, the i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by gelqf in the first k rows of its array argument A. On exit, the M-by-N matrix Q. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by gelqf. info: = 0: successful exit < 0: if info = -i, the i-th argument has an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); gelqf($a, $tau, $info); orglq($a, $tau, $info) unless $info != 0; =for bad orglq ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *orglq = \&PDL::orglq; =head2 ormlq =for sig Signature: ([phys]A(k,p); int side(); int trans(); [phys]tau(k); [io,phys]C(m,n);int [o,phys]info()) =for ref Overwrites the general real M-by-N matrix C with side = 0 side = 1 trans = 0: Q * C C * Q trans = 1: Q' * C C * Q' where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(k) . . . H(2) H(1) as returned by gelqf. Q is of order M if C = 0 and of order N if C = 1. Arguments ========= side: = 0: apply Q or Q' from the Left; = 1: apply Q or Q' from the Right. trans: = 0: No transpose, apply Q; = 1: Transpose, apply Q'. A: The i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by gelqf in the first k rows of its array argument A. A is modified by the routine but restored on exit. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by gelqf. C: On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $a = transpose($a); $info = null; $tau = zeroes(float, 50); gelqf($a, $tau, $info); $c = random(70,50); # $c will contain the result $c->reshape(70,100); $c = transpose($c); ormlq($a, $tau, $c, $info); =for bad ormlq ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ormlq = \&PDL::ormlq; =head2 geqlf =for sig Signature: ([io,phys]A(m,n); [o,phys]tau(k); int [o,phys]info()) =for ref Computes a QL factorization of a real M-by-N matrix A: A = Q * L The matrix Q is represented as a product of elementary reflectors Q = H(k) . . . H(2) H(1), where k = min(m,n). Each H(i) has the form H(i) = I - tau * v * v' where tau is a real scalar, and v is a real vector with v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in A(1:m-k+i-1,n-k+i), and tau in TAU(i). Arguments ========= A: On entry, the M-by-N matrix A. On exit, if m >= n, the lower triangle of the subarray A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; if m <= n, the elements on and below the (n-m)-th superdiagonal contain the M-by-N lower trapezoidal matrix L; the remaining elements, with the array tau, represent the orthogonal matrix Q as a product of elementary reflectors. tau: The scalar factors of the elementary reflectors. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); geqlf($a, $tau, $info); =for bad geqlf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *geqlf = \&PDL::geqlf; =head2 orgql =for sig Signature: ([io,phys]A(m,n); [phys]tau(k); int [o,phys]info()) =for ref Generates an M-by-N real matrix Q with orthonormal columns, which is defined as the last N columns of a product of K elementary reflectors of order M Q = H(k) . . . H(2) H(1) as returned by geqlf. Arguments ========= A: On entry, the (n-k+i)-th column must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by geqlf in the last k columns of its array argument A. On exit, the M-by-N matrix Q. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by geqlf. info: = 0: successful exit < 0: if info = -i, the i-th argument has an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); geqlf($a, $tau, $info); orgql($a, $tau, $info) unless $info != 0; =for bad orgql ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *orgql = \&PDL::orgql; =head2 ormql =for sig Signature: ([phys]A(p,k); int side(); int trans(); [phys]tau(k); [io,phys]C(m,n);int [o,phys]info()) =for ref Overwrites the general real M-by-N matrix C with side = 0 side = 1 trans = 0: Q * C C * Q trans = 1: Q' * C C * Q' where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(k) . . . H(2) H(1) as returned by geqlf. Q is of order M if C = 0 and of order N if C = 1. Arguments ========= side: = 0: apply Q or Q' from the Left; = 1: apply Q or Q' from the Right. trans: = 0: No transpose, apply Q; = 1: Transpose, apply Q'. A: The i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by geqlf in the last k rows of its array argument A. A is modified by the routine but restored on exit. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by geqlf. C: On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $a = transpose($a); $info = null; $tau = zeroes(float, 50); geqlf($a, $tau, $info); $c = random(70,50); # $c will contain the result $c->reshape(70,100); $c = transpose($c); ormql($a, $tau, $c, $info); =for bad ormql ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ormql = \&PDL::ormql; =head2 gerqf =for sig Signature: ([io,phys]A(m,n); [o,phys]tau(k); int [o,phys]info()) =for ref Computes an RQ factorization of a real M-by-N matrix A: A = R * Q. The matrix Q is represented as a product of elementary reflectors Q = H(1) H(2) . . . H(k), where k = min(m,n). Each H(i) has the form H(i) = I - tau * v * v' where tau is a real scalar, and v is a real vector with v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). Arguments ========= A: On entry, the M-by-N matrix A. On exit, if m <= n, the upper triangle of the subarray A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; if m >= n, the elements on and above the (m-n)-th subdiagonal contain the M-by-N upper trapezoidal matrix R; the remaining elements, with the array tau, represent the orthogonal matrix Q as a product of min(m,n) elementary reflectors (see Further Details). tau: The scalar factors of the elementary reflectors. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); gerqf($a, $tau, $info); =for bad gerqf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gerqf = \&PDL::gerqf; =head2 orgrq =for sig Signature: ([io,phys]A(m,n); [phys]tau(k); int [o,phys]info()) =for ref Generates an M-by-N real matrix Q with orthonormal rows, which is defined as the last M rows of a product of K elementary reflectors of order N Q = H(1) H(2) . . . H(k) as returned by gerqf. Arguments ========= A: On entry, the (m-k+i)-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by gerqf in the last k rows of its array argument A. On exit, the M-by-N matrix Q. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by gerqf. info: = 0: successful exit < 0: if info = -i, the i-th argument has an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); gerqf($a, $tau, $info); orgrq($a, $tau, $info) unless $info != 0; =for bad orgrq ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *orgrq = \&PDL::orgrq; =head2 ormrq =for sig Signature: ([phys]A(k,p); int side(); int trans(); [phys]tau(k); [io,phys]C(m,n);int [o,phys]info()) =for ref Overwrites the general real M-by-N matrix C with side = 0 side = 1 trans = 0: Q * C C * Q trans = 1: Q' * C C * Q' where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(1) H(2) . . . H(k) as returned by gerqf. Q is of order M if C = 0 and of order N if C = 1. Arguments ========= side: = 0: apply Q or Q' from the Left; = 1: apply Q or Q' from the Right. trans: = 0: No transpose, apply Q; = 1: Transpose, apply Q'. A: The i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by gerqf in the last k rows of its array argument A. A is modified by the routine but restored on exit. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by gerqf. C: On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $a = transpose($a); $info = null; $tau = zeroes(float, 50); gerqf($a, $tau, $info); $c = random(70,50); # $c will contain the result $c->reshape(70,100); $c = transpose($c); ormrq($a, $tau, $c, $info); =for bad ormrq ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ormrq = \&PDL::ormrq; =head2 tzrzf =for sig Signature: ([io,phys]A(m,n); [o,phys]tau(k); int [o,phys]info()) =for ref Reduces the M-by-N ( M <= N ) real upper trapezoidal matrix A to upper triangular form by means of orthogonal transformations. The upper trapezoidal matrix A is factored as A = ( R 0 ) * Z, where Z is an N-by-N orthogonal matrix and R is an M-by-M upper triangular matrix. The factorization is obtained by Householder's method. The kth transformation matrix, Z( k ), which is used to introduce zeros into the ( m - k + 1 )th row of A, is given in the form Z( k ) = ( I 0 ), ( 0 T( k ) ) where T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), ( 0 ) ( z( k ) ) tau is a scalar and z( k ) is an ( n - m ) element vector. tau and z( k ) are chosen to annihilate the elements of the kth row of X. The scalar tau is returned in the kth element of C and the vector u( k ) in the kth row of A, such that the elements of z( k ) are in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in the upper triangular part of A. Z is given by Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). Arguments ========= A: On entry, the leading M-by-N upper trapezoidal part of the array A must contain the matrix to be factorized. On exit, the leading M-by-M upper triangular part of A contains the upper triangular matrix R, and elements M+1 to N of the first M rows of A, with the array tau, represent the orthogonal matrix Z as a product of M elementary reflectors. tau: The scalar factors of the elementary reflectors. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $info = null; $tau = zeroes(float, 50); tzrzf($a, $tau, $info); =for bad tzrzf ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *tzrzf = \&PDL::tzrzf; =head2 ormrz =for sig Signature: ([phys]A(k,p); int side(); int trans(); [phys]tau(k); [io,phys]C(m,n);int [o,phys]info()) =for ref Overwrites the general real M-by-N matrix C with side = 0 side = 1 trans = 0: Q * C C * Q trans = 1: Q' * C C * Q' where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(1) H(2) . . . H(k) as returned by tzrzf. Q is of order M if C = 0 and of order N if C = 1. Arguments ========= side: = 0: apply Q or Q' from the Left; = 1: apply Q or Q' from the Right. trans: = 0: No transpose, apply Q; = 1: Transpose, apply Q'. A: The i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by tzrzf in the last k rows of its array argument A. A is modified by the routine but restored on exit. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by tzrzf. C: On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $a = transpose($a); $info = null; $tau = zeroes(float, 50); tzrzf($a, $tau, $info); $c = random(70,50); # $c will contain the result $c->reshape(70,100); $c = transpose($c); ormrz($a, $tau, $c, $info); =for bad ormrz ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ormrz = \&PDL::ormrz; =head2 gehrd =for sig Signature: ([io,phys]A(n,n); int [phys]ilo();int [phys]ihi();[o,phys]tau(k); int [o,phys]info()) =for ref Reduces a real general matrix A to upper Hessenberg form H by an orthogonal similarity transformation: Q' * A * Q = H . Further Details =============== The matrix Q is represented as a product of (ihi-ilo) elementary reflectors Q = H(ilo) H(ilo+1) . . . H(ihi-1). Each H(i) has the form H(i) = I - tau * v * v' where tau is a real scalar, and v is a real vector with v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on exit in A(i+2:ihi,i), and tau in tau(i). The contents of A are illustrated by the following example, with n = 7, ilo = 2 and ihi = 6: on entry, on exit, ( a a a a a a a ) ( a a h h h h a ) ( a a a a a a ) ( a h h h h a ) ( a a a a a a ) ( h h h h h h ) ( a a a a a a ) ( v2 h h h h h ) ( a a a a a a ) ( v2 v3 h h h h ) ( a a a a a a ) ( v2 v3 v4 h h h ) ( a ) ( a ) where a denotes an element of the original matrix A, h denotes a modified element of the upper Hessenberg matrix H, and vi denotes an element of the vector defining H(i). Arguments ========= ilo: ihi: It is assumed that A is already upper triangular in rows and columns 1:ilo-1 and ihi+1:N. ilo and ihi are normally set by a previous call to gebal; otherwise they should be set to 1 and N respectively. See Further Details. 1 <= ilo <= ihi <= N, if N > 0; ilo=1 and ihi=0, if N=0. A: On entry, the N-by-N general matrix to be reduced. On exit, the upper triangle and the first subdiagonal of A are overwritten with the upper Hessenberg matrix H, and the elements below the first subdiagonal, with the array tau, represent the orthogonal matrix Q as a product of elementary reflectors. See Further Details. tau: The scalar factors of the elementary reflectors (see Further Details). Elements 1:ilo-1 and ihi:N-1 of tau are set to zero. (dimension (N-1)) info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random (50, 50); $info = null; $tau = zeroes(50); gehrd($a, 1, 50, $tau, $info); =for bad gehrd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gehrd = \&PDL::gehrd; =head2 orghr =for sig Signature: ([io,phys]A(n,n); int [phys]ilo();int [phys]ihi();[phys]tau(k); int [o,phys]info()) =for ref Generates a real orthogonal matrix Q which is defined as the product of ihi-ilo elementary reflectors of order N, as returned by C: Q = H(ilo) H(ilo+1) . . . H(ihi-1). Arguments ========= ilo: ihi: ilo and ihi must have the same values as in the previous call of gehrd. Q is equal to the unit matrix except in the submatrix Q(ilo+1:ihi,ilo+1:ihi). 1 <= ilo <= ihi <= N, if N > 0; ilo=1 and ihi=0, if N=0. A: On entry, the vectors which define the elementary reflectors, as returned by gehrd. On exit, the N-by-N orthogonal matrix Q. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by gehrd.(dimension (N-1)) info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (50, 50); $info = null; $tau = zeroes(50); gehrd($a, 1, 50, $tau, $info); orghr($a, 1, 50, $tau, $info); =for bad orghr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *orghr = \&PDL::orghr; =head2 hseqr =for sig Signature: ([io,phys]H(n,n); int job();int compz();int [phys]ilo();int [phys]ihi();[o,phys]wr(n); [o,phys]wi(n);[o,phys]Z(m,m); int [o,phys]info()) =for ref Computes the eigenvalues of a real upper Hessenberg matrix H and, optionally, the matrices T and Z from the Schur decomposition H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur form), and Z is the orthogonal matrix of Schur vectors. Optionally Z may be postmultiplied into an input orthogonal matrix Q, so that this routine can give the Schur factorization of a matrix A which has been reduced to the Hessenberg form H by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. Arguments ========= job: = 0: compute eigenvalues only; = 1: compute eigenvalues and the Schur form T. compz: = 0: no Schur vectors are computed; = 1: Z is initialized to the unit matrix and the matrix Z of Schur vectors of H is returned; = 2: Z must contain an orthogonal matrix Q on entry, and the product Q*Z is returned. ilo: ihi: It is assumed that H is already upper triangular in rows and columns 1:ilo-1 and ihi+1:N. ilo and ihi are normally set by a previous call to gebal, and then passed to gehrd when the matrix output by gebal is reduced to Hessenberg form. Otherwise ilo and ihi should be set to 1 and N respectively. 1 <= ilo <= ihi <= N, if N > 0; ilo=1 and ihi=0, if N=0. H: On entry, the upper Hessenberg matrix H. On exit, if job = 1, H contains the upper quasi-triangular matrix T from the Schur decomposition (the Schur form); 2-by-2 diagonal blocks (corresponding to complex conjugate pairs of eigenvalues) are returned in standard form, with H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If job = 0, the contents of H are unspecified on exit. wr: wi: The real and imaginary parts, respectively, of the computed eigenvalues. If two eigenvalues are computed as a complex conjugate pair, they are stored in consecutive elements of wr and wi, say the i-th and (i+1)th, with wi(i) > 0 and wi(i+1) < 0. If job = 1, the eigenvalues are stored in the same order as on the diagonal of the Schur form returned in H, with wr(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal block, wi(i) = sqrt(H(i+1,i)*H(i,i+1)) and wi(i+1) = -wi(i). Z: If compz = 0: Z is not referenced. If compz = 1: on entry, Z need not be set, and on exit, Z contains the orthogonal matrix Z of the Schur vectors of H. If compz = 2: on entry Z must contain an N-by-N matrix Q, which is assumed to be equal to the unit matrix except for the submatrix Z(ilo:ihi,ilo:ihi); on exit Z contains Q*Z. Normally Q is the orthogonal matrix generated by orghr after the call to gehrd which formed the Hessenberg matrix H. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, hseqr failed to compute all of the eigenvalues in a total of 30*(ihi-ilo+1) iterations; elements 1:ilo-1 and i+1:n of wr and wi contain those eigenvalues which have been successfully computed. =for example $a = random (50, 50); $info = null; $tau = zeroes(50); $z= zeroes(1,1); gehrd($a, 1, 50, $tau, $info); hseqr($a,0,0,1,50,($wr=null),($wi=null),$z,$info); =for bad hseqr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *hseqr = \&PDL::hseqr; =head2 trevc =for sig Signature: ([io,phys]T(n,n); int side();int howmny();int [phys]select(q);[io,phys]VL(m,r); [io,phys]VR(p,s);int [o,phys]m(); int [o,phys]info()) =for ref Computes some or all of the right and/or left eigenvectors of a real upper quasi-triangular matrix T. The right eigenvector x and the left eigenvector y of T corresponding to an eigenvalue w are defined by: T*x = w*x, y'*T = w*y' where y' denotes the conjugate transpose of the vector y. If all eigenvectors are requested, the routine may either return the matrices X and/or Y of right or left eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an input orthogonal matrix. If T was obtained from the real-Schur factorization of an original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of right or left eigenvectors of A. T must be in Schur canonical form (as returned by hseqr), that is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its diagonal elements equal and its off-diagonal elements of opposite sign. Corresponding to each 2-by-2 diagonal block is a complex conjugate pair of eigenvalues and eigenvectors; only one eigenvector of the pair is computed, namely the one corresponding to the eigenvalue with positive imaginary part. Further Details =============== The algorithm used in this program is basically backward (forward) substitution, with scaling to make the the code robust against possible overflow. Each eigenvector is normalized so that the element of largest magnitude has magnitude 1; here the magnitude of a complex number (x,y) is taken to be |x| + |y|. Arguments ========= side: = 0 : compute both right and left eigenvectors; = 1 : compute right eigenvectors only; = 2 : compute left eigenvectors only. howmny: = 0: compute all right and/or left eigenvectors; = 1: compute all right and/or left eigenvectors, and backtransform them using the input matrices supplied in VR and/or VL; = 2: compute selected right and/or left eigenvectors, specified by the logical array select. select: If howmny = 2, select specifies the eigenvectors to be computed. If howmny = 0 or 1, select is not referenced. To select the real eigenvector corresponding to a real eigenvalue w(j), select(j) must be set to TRUE. To select the complex eigenvector corresponding to a complex conjugate pair w(j) and w(j+1), either select(j) or select(j+1) must be set to TRUE; then on exit select(j) is TRUE and select(j+1) is FALSE. T: The upper quasi-triangular matrix T in Schur canonical form. VL: On entry, if side = 2 or 0 and howmny = 1, VL must contain an N-by-N matrix Q (usually the orthogonal matrix Q of Schur vectors returned by hseqr). On exit, if side = 2 or 0, VL contains: if howmny = 0, the matrix Y of left eigenvectors of T; VL has the same quasi-lower triangular form as T'. If T(i,i) is a real eigenvalue, then the i-th column VL(i) of VL is its corresponding eigenvector. If T(i:i+1,i:i+1) is a 2-by-2 block whose eigenvalues are complex-conjugate eigenvalues of T, then VL(i)+sqrt(-1)*VL(i+1) is the complex eigenvector corresponding to the eigenvalue with positive real part. if howmny = 1, the matrix Q*Y; if howmny = 2, the left eigenvectors of T specified by select, stored consecutively in the columns of VL, in the same order as their eigenvalues. A complex eigenvector corresponding to a complex eigenvalue is stored in two consecutive columns, the first holding the real part, and the second the imaginary part. If side = 1, VL is not referenced. VR: On entry, if side = 1 or 0 and howmny = 1, VR must contain an N-by-N matrix Q (usually the orthogonal matrix Q of Schur vectors returned by hseqr). On exit, if side = 1 or 0, VR contains: if howmny = 0, the matrix X of right eigenvectors of T; VR has the same quasi-upper triangular form as T. If T(i,i) is a real eigenvalue, then the i-th column VR(i) of VR is its corresponding eigenvector. If T(i:i+1,i:i+1) is a 2-by-2 block whose eigenvalues are complex-conjugate eigenvalues of T, then VR(i)+sqrt(-1)*VR(i+1) is the complex eigenvector corresponding to the eigenvalue with positive real part. if howmny = 1, the matrix Q*X; if howmny = 2, the right eigenvectors of T specified by select, stored consecutively in the columns of VR, in the same order as their eigenvalues. A complex eigenvector corresponding to a complex eigenvalue is stored in two consecutive columns, the first holding the real part and the second the imaginary part. If side = 2, VR is not referenced. m: The number of columns in the arrays VL and/or VR actually used to store the eigenvectors. If howmny = 0 or 1, m is set to N. Each selected real eigenvector occupies one column and each selected complex eigenvector occupies two columns. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (50, 50); $info = null; $tau = zeroes(50); $z= zeroes(1,1); gehrd($a, 1, 50, $tau, $info); hseqr($a,0,0,1,50,($wr=null),($wi=null),$z,$info); =for bad trevc ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *trevc = \&PDL::trevc; =head2 tgevc =for sig Signature: ([io,phys]A(n,n); int side();int howmny();[io,phys]B(n,n);int [phys]select(q);[io,phys]VL(m,r); [io,phys]VR(p,s);int [o,phys]m(); int [o,phys]info()) =for ref Computes some or all of the right and/or left generalized eigenvectors of a pair of real upper triangular matrices (A,B). The right generalized eigenvector x and the left generalized eigenvector y of (A,B) corresponding to a generalized eigenvalue w are defined by: (A - wB) * x = 0 and y**H * (A - wB) = 0 where y**H denotes the conjugate tranpose of y. If an eigenvalue w is determined by zero diagonal elements of both A and B, a unit vector is returned as the corresponding eigenvector. If all eigenvectors are requested, the routine may either return the matrices X and/or Y of right or left eigenvectors of (A,B), or the products Z*X and/or Q*Y, where Z and Q are input orthogonal matrices. If (A,B) was obtained from the generalized real-Schur factorization of an original pair of matrices (A0,B0) = (Q*A*Z**H,Q*B*Z**H), then Z*X and Q*Y are the matrices of right or left eigenvectors of A. A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal blocks. Corresponding to each 2-by-2 diagonal block is a complex conjugate pair of eigenvalues and eigenvectors; only one eigenvector of the pair is computed, namely the one corresponding to the eigenvalue with positive imaginary part. Arguments ========= side: = 0 : compute both right and left eigenvectors; = 1 : compute right eigenvectors only; = 2 : compute left eigenvectors only. howmny: = 0 : compute all right and/or left eigenvectors; = 1 : compute all right and/or left eigenvectors, and backtransform them using the input matrices supplied in VR and/or VL; = 2 : compute selected right and/or left eigenvectors, specified by the logical array select. select: If howmny=2, select specifies the eigenvectors to be computed. If howmny=0 or 1, select is not referenced. To select the real eigenvector corresponding to the real eigenvalue w(j), select(j) must be set to TRUE To select the complex eigenvector corresponding to a complex conjugate pair w(j) and w(j+1), either select(j) or select(j+1) must be set to TRUE. A: The upper quasi-triangular matrix A. B: The upper triangular matrix B. If A has a 2-by-2 diagonal block, then the corresponding 2-by-2 block of B must be diagonal with positive elements. VL: On entry, if side = 2 or 0 and howmny = 1, VL must contain an N-by-N matrix Q (usually the orthogonal matrix Q of left Schur vectors returned by hgqez). On exit, if side = 2 or 0, VL contains: if howmny = 0, the matrix Y of left eigenvectors of (A,B); if howmny = 1, the matrix Q*Y; if howmny = 2, the left eigenvectors of (A,B) specified by select, stored consecutively in the columns of VL, in the same order as their eigenvalues. If side = 1, VL is not referenced. A complex eigenvector corresponding to a complex eigenvalue is stored in two consecutive columns, the first holding the real part, and the second the imaginary part. VR: On entry, if side = 1 or 0 and howmny = 1, VR must contain an N-by-N matrix Q (usually the orthogonal matrix Z of right Schur vectors returned by hgeqz). On exit, if side = 1 or 0, VR contains: if howmny = 0, the matrix X of right eigenvectors of (A,B); if howmny = 1, the matrix Z*X; if howmny = 2, the right eigenvectors of (A,B) specified by select, stored consecutively in the columns of VR, in the same order as their eigenvalues. If side = 2, VR is not referenced. A complex eigenvector corresponding to a complex eigenvalue is stored in two consecutive columns, the first holding the real part and the second the imaginary part. M: The number of columns in the arrays VL and/or VR actually used to store the eigenvectors. If howmny = 0 or 1, M is set to N. Each selected real eigenvector occupies one column and each selected complex eigenvector occupies two columns. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. > 0: the 2-by-2 block (info:info+1) does not have a complex eigenvalue. =for example $a = random (50, 50); $info = null; $tau = zeroes(50); $z= zeroes(1,1); gehrd($a, 1, 50, $tau, $info); hseqr($a,0,0,1,50,($wr=null),($wi=null),$z,$info); =for bad tgevc ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *tgevc = \&PDL::tgevc; =head2 gebal =for sig Signature: ([io,phys]A(n,n); int job(); int [o,phys]ilo();int [o,phys]ihi();[o,phys]scale(n); int [o,phys]info()) =for ref Balances a general real matrix A. This involves, first, permuting A by a similarity transformation to isolate eigenvalues in the first 1 to ilo-1 and last ihi+1 to N elements on the diagonal; and second, applying a diagonal similarity transformation to rows and columns ilo to ihi to make the rows and columns as close in norm as possible. Both steps are optional. Balancing may reduce the 1-norm of the matrix, and improve the accuracy of the computed eigenvalues and/or eigenvectors. Further Details =============== The permutations consist of row and column interchanges which put the matrix in the form ( T1 X Y ) P A P = ( 0 B Z ) ( 0 0 T2 ) where T1 and T2 are upper triangular matrices whose eigenvalues lie along the diagonal. The column indices ilo and ihi mark the starting and ending columns of the submatrix B. Balancing consists of applying a diagonal similarity transformation inv(D) * B * D to make the 1-norms of each row of B and its corresponding column nearly equal. The output matrix is ( T1 X*D Y ) ( 0 inv(D)*B*D inv(D)*Z ). ( 0 0 T2 ) Information about the permutations P and the diagonal matrix D is returned in the vector C. Arguments ========= job: Specifies the operations to be performed on A: = 0: none: simply set ilo = 1, ihi = N, scale(I) = 1.0 for i = 1,...,N; = 1: permute only; = 2: scale only; = 3: both permute and scale. A: On entry, the input matrix A. On exit, A is overwritten by the balanced matrix. If job = 0, A is not referenced. See Further Details. ilo: ihi: ilo and ihi are set to integers such that on exit A(i,j) = 0 if i > j and j = 1,...,ilo-1 or I = ihi+1,...,N. If job = 0 or 2, ilo = 1 and ihi = N. scale: Details of the permutations and scaling factors applied to A. If P(j) is the index of the row and column interchanged with row and column j and D(j) is the scaling factor applied to row and column j, then scale(j) = P(j) for j = 1,...,ilo-1 = D(j) for j = ilo,...,ihi = P(j) for j = ihi+1,...,N. The order in which the interchanges are made is N to ihi+1, then 1 to ilo-1. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random (50, 50); $scale = zeroes(50); $info = null; $ilo = null; $ihi = null; gebal($a, $ilo, $ihi, $scale, $info); =for bad gebal ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gebal = \&PDL::gebal; =head2 gebak =for sig Signature: ([io,phys]A(n,m); int job(); int side();int [phys]ilo();int [phys]ihi();[phys]scale(n); int [o,phys]info()) =for ref gebak forms the right or left eigenvectors of a real general matrix by backward transformation on the computed eigenvectors of the balanced matrix output by gebal. Arguments ========= A: On entry, the matrix of right or left eigenvectors to be transformed, as returned by hsein or trevc. On exit, A is overwritten by the transformed eigenvectors. job: Specifies the type of backward transformation required: = 0 , do nothing, return immediately; = 1, do backward transformation for permutation only; = 2, do backward transformation for scaling only; = 3, do backward transformations for both permutation and scaling. job must be the same as the argument job supplied to gebal. side: = 0: V contains left eigenvectors. = 1: V contains right eigenvectors; ilo: ihi: The integers ilo and ihi determined by gebal. 1 <= ilo <= ihi <= N, if N > 0; ilo=1 and ihi=0, if N=0. Here N is the the number of rows of the matrix A. scale: Details of the permutation and scaling factors, as returned by gebal. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random (50, 50); $scale = zeroes(50); $info = null; $ilo = null; $ihi = null; gebal($a, $ilo, $ihi, $scale, $info); # Compute eigenvectors ($ev) gebak($ev, $ilo, $ihi, $scale, $info); =for bad gebak ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gebak = \&PDL::gebak; =head2 lange =for sig Signature: ([phys]A(n,m); int norm(); [o]b()) =for ref Computes the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real matrix A. Description =========== returns the value lange = ( max(abs(A(i,j))), norm = 0 ( ( norm1(A), norm = 1 ( ( normI(A), norm = 2 ( ( normF(A), norm = 3 where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. Arguments ========= norm: Specifies the value to be returned in lange as described above. A: The n by m matrix A. =for example $a = random (float, 100, 100); $norm = $a->lange(1); =for bad lange ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *lange = \&PDL::lange; =head2 lansy =for sig Signature: ([phys]A(n,n); int uplo(); int norm(); [o]b()) =for ref Computes the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix A. Description =========== returns the value lansy = ( max(abs(A(i,j))), norm = 0 ( ( norm1(A), norm = 1 ( ( normI(A), norm = 2 ( ( normF(A), norm = 3 where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. norm: Specifies the value to be returned in lansy as described above. uplo: Specifies whether the upper or lower triangular part of the symmetric matrix A is to be referenced. = 0: Upper triangular part of A is referenced = 1: Lower triangular part of A is referenced A: The symmetric matrix A. If uplo = 0, the leading n by n upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading n by n lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. =for example # Assume $a is symmetric $a = random (float, 100, 100); $norm = $a->lansy(1, 1); =for bad lansy ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *lansy = \&PDL::lansy; =head2 lantr =for sig Signature: ([phys]A(m,n);int uplo();int norm();int diag();[o]b()) =for ref Computes the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix A. Description =========== returns the value lantr = ( max(abs(A(i,j))), norm = 0 ( ( norm1(A), norm = 1 ( ( normI(A), norm = 2 ( ( normF(A), norm = 3 where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. norm: Specifies the value to be returned in lantr as described above. uplo: Specifies whether the matrix A is upper or lower trapezoidal. = 0: Upper triangular part of A is referenced = 1: Lower triangular part of A is referenced Note that A is triangular instead of trapezoidal if M = N. diag: Specifies whether or not the matrix A has unit diagonal. = 0: Non-unit diagonal = 1: Unit diagonal A: The trapezoidal matrix A (A is triangular if m = n). If uplo = 0, the leading m by n upper trapezoidal part of the array A contains the upper trapezoidal matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading m by n lower trapezoidal part of the array A contains the lower trapezoidal matrix, and the strictly upper triangular part of A is not referenced. Note that when diag = 1, the diagonal elements of A are not referenced and are assumed to be one. =for example # Assume $a is upper triangular $a = random (float, 100, 100); $norm = $a->lantr(1, 1, 0); =for bad lantr ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *lantr = \&PDL::lantr; =head2 gemm =for sig Signature: ([phys]A(m,n); int transa(); int transb(); [phys]B(p,q);[phys]alpha(); [phys]beta(); [io,phys]C(r,s)) =for ref Performs one of the matrix-matrix operations C := alpha*op( A )*op( B ) + beta*C, where op( X ) is one of p( X ) = X or op( X ) = X', alpha and beta are scalars, and A, B and C are matrices, with op( A ) an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. Parameters ========== transa: On entry, transa specifies the form of op( A ) to be used in the matrix multiplication as follows: transa = 0, op( A ) = A. transa = 1, op( A ) = A'. transb: On entry, transb specifies the form of op( B ) to be used in the matrix multiplication as follows: transb = 0, op( B ) = B. transb = 1, op( B ) = B'. alpha: On entry, alpha specifies the scalar alpha. A: Before entry with transa = 0, the leading m by k part of the array A must contain the matrix A, otherwise the leading k by m part of the array A must contain the matrix A. B: Before entry with transb = 0, the leading k by n part of the array B must contain the matrix B, otherwise the leading n by k part of the array B must contain the matrix B. beta: On entry, beta specifies the scalar beta. When beta is supplied as zero then C need not be set on input. C: Before entry, the leading m by n part of the array C must contain the matrix C, except when beta is zero, in which case C need not be set on entry. On exit, the array C is overwritten by the m by n matrix ( alpha*op( A )*op( B ) + beta*C ). =for example $a = random(5,4); $b = random(5,4); $alpha = pdl(0.5); $beta = pdl(0); $c = zeroes(5,5); gemm($a, 0, 1,$b, $alpha, $beta, $c); =for bad gemm ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gemm = \&PDL::gemm; =head2 mmult =for sig Signature: ([phys]A(m,n); [phys]B(p,m); [o,phys]C(p,n)) =for ref Blas matrix multiplication based on gemm =for bad mmult ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mmult = \&PDL::mmult; =head2 crossprod =for sig Signature: ([phys]A(n,m); [phys]B(p,m); [o,phys]C(p,n)) =for ref Blas matrix cross product based on gemm =for bad crossprod ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *crossprod = \&PDL::crossprod; =head2 syrk =for sig Signature: ([phys]A(m,n); int uplo(); int trans(); [phys]alpha(); [phys]beta(); [io,phys]C(p,p)) =for ref Performs one of the symmetric rank k operations C := alpha*A*A' + beta*C, or C := alpha*A'*A + beta*C, where alpha and beta are scalars, C is an n by n symmetric matrix and A is an n by k matrix in the first case and a k by n matrix in the second case. Parameters ========== uplo: On entry, uplo specifies whether the upper or lower triangular part of the array C is to be referenced as follows: uplo = 0 Only the upper triangular part of C is to be referenced. uplo = 1 Only the lower triangular part of C is to be referenced. Unchanged on exit. trans: On entry, trans specifies the operation to be performed as follows: trans = 0 C := alpha*A*A' + beta*C. trans = 1 C := alpha*A'*A + beta*C. alpha: On entry, alpha specifies the scalar alpha. Unchanged on exit. A: Before entry with trans = 0, the leading n by k part of the array A must contain the matrix A, otherwise the leading k by n part of the array A must contain the matrix A. beta: On entry, beta specifies the scalar beta. C: Before entry with uplo = 0, the leading n by n upper triangular part of the array C must contain the upper triangular part of the symmetric matrix and the strictly lower triangular part of C is not referenced. On exit, the upper triangular part of the array C is overwritten by the upper triangular part of the updated matrix. Before entry with uplo = 1, the leading n by n lower triangular part of the array C must contain the lower triangular part of the symmetric matrix and the strictly upper triangular part of C is not referenced. On exit, the lower triangular part of the array C is overwritten by the lower triangular part of the updated matrix. =for example $a = random(5,4); $b = zeroes(5,5); $alpha = 1; $beta = 0; syrk ($a, 1,0,$alpha, $beta , $b); =for bad syrk ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *syrk = \&PDL::syrk; =head2 dot =for sig Signature: ([phys]a(n);int [phys]inca();[phys]b(m);int [phys]incb();[o,phys]c()) =for ref Dot product of two vectors using Blas. =for example $a = random(5); $b = random(5); $c = dot($a, 1, $b, 1) =for bad dot ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *dot = \&PDL::dot; =head2 axpy =for sig Signature: ([phys]a(n);int [phys]inca();[phys] alpha();[io,phys]b(m);int [phys]incb()) =for ref Linear combination of vectors ax + b using Blas. Returns result in b. =for example $a = random(5); $b = random(5); axpy($a, 1, 12, $b, 1) =for bad axpy ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *axpy = \&PDL::axpy; =head2 nrm2 =for sig Signature: ([phys]a(n);int [phys]inca();[o,phys]b()) =for ref Euclidean norm of a vector using Blas. =for example $a = random(5); $norm2 = norm2($a,1) =for bad nrm2 ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *nrm2 = \&PDL::nrm2; =head2 asum =for sig Signature: ([phys]a(n);int [phys]inca();[o,phys]b()) =for ref Sum of absolute values of a vector using Blas. =for example $a = random(5); $absum = asum($a,1) =for bad asum ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *asum = \&PDL::asum; =head2 scal =for sig Signature: ([io,phys]a(n);int [phys]inca();[phys]scale()) =for ref Scale a vector by a constant using Blas. =for example $a = random(5); $a->scal(1, 0.5) =for bad scal ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *scal = \&PDL::scal; =head2 rot =for sig Signature: ([io,phys]a(n);int [phys]inca();[phys]c(); [phys]s();[io,phys]b(n);int [phys]incb()) =for ref Applies plane rotation using Blas. =for example $a = random(5); $b = random(5); rot($a, 1, 0.5, 0.7, $b, 1) =for bad rot ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *rot = \&PDL::rot; =head2 rotg =for sig Signature: ([io,phys]a();[io,phys]b();[o,phys]c(); [o,phys]s()) =for ref Generates plane rotation using Blas. =for example $a = sequence(4); rotg($a(0), $a(1),$a(2),$a(3)) =for bad rotg ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *rotg = \&PDL::rotg; =head2 lasrt =for sig Signature: ([io,phys]d(n); int id();int [o,phys]info()) =for ref Sort the numbers in d in increasing order (if id = 0) or in decreasing order (if id = 1 ). Use Quick Sort, reverting to Insertion sort on arrays of size <= 20. Dimension of stack limits N to about 2**32. Arguments ========= id: = 0: sort d in increasing order; = 1: sort d in decreasing order. d: On entry, the array to be sorted. On exit, d has been sorted into increasing order (d(1) <= ... <= d(N) ) or into decreasing order (d(1) >= ... >= d(N) ), depending on id. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random(5); lasrt ($a, 0, ($info = null)); =for bad lasrt ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *lasrt = \&PDL::lasrt; =head2 lacpy =for sig Signature: ([phys]A(m,n); int uplo(); [o,phys]B(p,n)) =for ref Copies all or part of a two-dimensional matrix A to another matrix B. Arguments ========= uplo: Specifies the part of the matrix A to be copied to B. = 0: Upper triangular part = 1: Lower triangular part Otherwise: All of the matrix A A: The m by n matrix A. If uplo = 0, only the upper triangle or trapezoid is accessed; if uplo = 1, only the lower triangle or trapezoid is accessed. B: On exit, B = A in the locations specified by uplo. =for example $a = random(5,5); $b = zeroes($a); lacpy ($a, 0, $b); =for bad lacpy ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *lacpy = \&PDL::lacpy; =head2 laswp =for sig Signature: ([io,phys]A(m,n);int [phys]k1();int [phys] k2(); int [phys]ipiv(p);int [phys]inc()) =for ref Performs a series of row interchanges on the matrix A. One row interchange is initiated for each of rows k1 through k2 of A. Dosen't use PDL indice (start = 1). Arguments ========= A: On entry, the matrix of column dimension N to which the row interchanges will be applied. On exit, the permuted matrix. k1: The first element of ipiv for which a row interchange will be done. k2: The last element of ipiv for which a row interchange will be done. ipiv: The vector of pivot indices. Only the elements in positions k1 through k2 of ipiv are accessed. ipiv(k) = l implies rows k and l are to be interchanged. inc: The increment between successive values of ipiv. If ipiv is negative, the pivots are applied in reverse order. =for example $a = random(5,5); # reverse row (col for PDL) $b = pdl([5,4,3,2,1]); $a->laswp(1,2,$b,1); =for bad laswp ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *laswp = \&PDL::laswp; =head2 lamch =for sig Signature: (cmach(); [o]precision()) =for ref Determines precision machine parameters. Works inplace. Arguments ========= cmach: Specifies the value to be returned by lamch: = 0 LAMCH := eps = 1 LAMCH := sfmin = 2 LAMCH := base = 3 LAMCH := eps*base = 4 LAMCH := t = 5 LAMCH := rnd = 6 LAMCH := emin = 7 LAMCH := rmin = 8 LAMCH := emax = 9 LAMCH := 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) =for example $a = lamch (0); print "EPS is $a for double\n"; =for bad lamch ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *lamch = \&PDL::lamch; =head2 labad =for sig Signature: ([io,phys]small(); [io,phys]large()) =for ref Takes as input the values computed by C for underflow and overflow, and returns the square root of each of these values if the log of large is sufficiently large. This subroutine is intended to identify machines with a large exponent range, such as the Crays, and redefine the underflow and overflow limits to be the square roots of the values computed by C. This subroutine is needed because lamch does not compensate for poor arithmetic in the upper half of the exponent range, as is found on a Cray. Arguments ========= small: On entry, the underflow threshold as computed by lamch. On exit, if LOG10(large) is sufficiently large, the square root of small, otherwise unchanged. large: On entry, the overflow threshold as computed by lamch. On exit, if LOG10(large) is sufficiently large, the square root of large, otherwise unchanged. =for example $underflow = lamch(7); $overflow = lamch(9); labad ($underflow, $overflow); =for bad labad ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *labad = \&PDL::labad; =head2 tricpy =for sig Signature: (A(m,n);int uplo();[o] C(m,n)) =for ref Copy triangular part to another matrix. If uplo == 0 copy upper triangular part. =for bad tricpy does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *tricpy = \&PDL::tricpy; =head2 cplx_eigen =for sig Signature: (eigreval(n);eigimval(n); eigvec(n,p);int fortran();[o]cplx_val(q=2,n);[o]cplx_vec(r=2,n,p)) =for ref Output complex eigen-values/vectors from eigen-values/vectors as computed by geev or geevx. 'fortran' means fortran storage type. =for bad cplx_eigen does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cplx_eigen = \&PDL::cplx_eigen; =head2 augment =for sig Signature: (x(n); y(p);[o]out(q)) =for ref Combine two pidlles into a single piddle. This routine does backward and forward dataflow automatically. =for bad augment does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *augment = \&PDL::augment; =head2 mstack =for sig Signature: (x(n,m);y(n,p);[o]out(n,q)) =for ref Combine two pidlles into a single piddle. This routine does backward and forward dataflow automatically. =for bad mstack does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mstack = \&PDL::mstack; =head2 charpol =for sig Signature: ([phys]A(n,n);[phys,o]Y(n,n);[phys,o]out(p)) =for ref Compute adjoint matrix and characteristic polynomial. =for bad charpol does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *charpol = \&PDL::charpol; ; =head1 AUTHOR Copyright (C) Grégory Vanuxem 2005-2007. This library is free software; you can redistribute it and/or modify it under the terms of the artistic license as specified in the Artistic file. =cut # Exit with OK status 1; PDL-LinearAlgebra-0.12/GENERATED/PDL/LinearAlgebra/Trans.pm0000644113142400244210000006432012535325334025023 0ustar chris.h.marshallDomain Users # # GENERATED WITH PDL::PP! Don't modify! # package PDL::LinearAlgebra::Trans; @EXPORT_OK = qw( mexp mexpts mlog msqrt mpow mcos msin mtan msec mcsc mcot mcosh msinh mtanh msech mcsch mcoth macos masin matan masec macsc macot macosh masinh matanh masech macsch macoth sec asec sech asech cot acot acoth coth mfun csc acsc csch acsch toreal pi PDL::PP geexp PDL::PP cgeexp PDL::PP ctrsqrt PDL::PP ctrfun ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; $PDL::LinearAlgebra::Trans::VERSION = '0.12'; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::LinearAlgebra::Trans $VERSION; use PDL::Func; use PDL::Core; use PDL::Slices; use PDL::Ops qw//; use PDL::Math qw/floor/; use PDL::Complex; use PDL::NiceSlice; use PDL::LinearAlgebra; use PDL::LinearAlgebra::Real qw //; use PDL::LinearAlgebra::Complex qw //; use strict; =encoding Latin-1 =head1 NAME PDL::LinearAlgebra::Trans - Linear Algebra based transcendental functions for PDL =head1 SYNOPSIS use PDL::LinearAlgebra::Trans; $a = random (100,100); $sqrt = msqrt($a); =head1 DESCRIPTION This module provides some transcendental functions for matrices. Moreover it provides sec, asec, sech, asech, cot, acot, acoth, coth, csc, acsc, csch, acsch. Beware, importing this module will overwrite the hidden PDL routine sec. If you need to call it specify its origin module : PDL::Basic::sec(args) =head1 FUNCTIONS =cut =head2 geexp =for sig Signature: ([io,phys]A(n,n);int deg();scale();[io]trace();int [o]ns();int [o]info()) =for ref Computes exp(t*A), the matrix exponential of a general matrix, using the irreducible rational Pade approximation to the exponential function exp(x) = r(x) = (+/-)( I + 2*(q(x)/p(x)) ), combined with scaling-and-squaring and optionaly normalization of the trace. The algorithm is described in Roger B. Sidje (rbs.uq.edu.au) "EXPOKIT: Software Package for Computing Matrix Exponentials". ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 A: On input argument matrix. On output exp(t*A). Use Fortran storage type. deg: the degre of the diagonal Pade to be used. a value of 6 is generally satisfactory. scale: time-scale (can be < 0). trace: on input, boolean value indicating whether or not perform a trace normalization. On output value used. ns: on output number of scaling-squaring used. info: exit flag. 0 - no problem > 0 - Singularity in LU factorization when solving Pade approximation =for example = random(5,5); = pdl(1); ->xchg(0,1)->geexp(6,1,, ( = null), ( = null)); =for bad geexp does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *geexp = \&PDL::geexp; =head2 cgeexp =for sig Signature: ([io,phys]A(2,n,n);int deg();scale();int trace();int [o]ns();int [o]info()) =for ref Complex version of geexp. The value used for trace normalization is not returned. The algorithm is described in Roger B. Sidje (rbs@maths.uq.edu.au) "EXPOKIT: Software Package for Computing Matrix Exponentials". ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 =for bad cgeexp does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cgeexp = \&PDL::cgeexp; =head2 ctrsqrt =for sig Signature: ([io,phys]A(2,n,n);int uplo();[phys,o] B(2,n,n);int [o]info()) =for ref Root square of complex triangular matrix. Uses a recurrence of Björck and Hammarling. (See Nicholas J. Higham. A new sqrtm for MATLAB. Numerical Analysis Report No. 336, Manchester Centre for Computational Mathematics, Manchester, England, January 1999. It's available at http://www.ma.man.ac.uk/~higham/pap-mf.html) If uplo is true, A is lower triangular. =for bad ctrsqrt does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ctrsqrt = \&PDL::ctrsqrt; =head2 ctrfun =for sig Signature: ([io,phys]A(2,n,n);int uplo();[phys,o] B(2,n,n);int [o]info(); SV* func) =for ref Apply an arbitrary function to a complex triangular matrix. Uses a recurrence of Parlett. If uplo is true, A is lower triangular. =for bad ctrfun does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ctrfun = \&PDL::ctrfun; my $pi; BEGIN { $pi = pdl(3.1415926535897932384626433832795029) } sub pi () { $pi->copy }; *sec = \&PDL::sec; sub PDL::sec{1/cos($_[0])} *csc = \&PDL::csc; sub PDL::csc($) {1/sin($_[0])} *cot = \&PDL::cot; sub PDL::cot($) {1/(sin($_[0])/cos($_[0]))} *sech = \&PDL::sech; sub PDL::sech($){1/pdl($_[0])->cosh} *csch = \&PDL::csch; sub PDL::csch($) {1/pdl($_[0])->sinh} *coth = \&PDL::coth; sub PDL::coth($) {1/pdl($_[0])->tanh} *asec = \&PDL::asec; sub PDL::asec($) {my $tmp = 1/pdl($_[0]) ; $tmp->acos} *acsc = \&PDL::acsc; sub PDL::acsc($) {my $tmp = 1/pdl($_[0]) ; $tmp->asin} *acot = \&PDL::acot; sub PDL::acot($) {my $tmp = 1/pdl($_[0]) ; $tmp->atan} *asech = \&PDL::asech; sub PDL::asech($) {my $tmp = 1/pdl($_[0]) ; $tmp->acosh} *acsch = \&PDL::acsch; sub PDL::acsch($) {my $tmp = 1/pdl($_[0]) ; $tmp->asinh} *acoth = \&PDL::acoth; sub PDL::acoth($) {my $tmp = 1/pdl($_[0]) ; $tmp->atanh} my $_tol = 9.99999999999999e-15; sub toreal{ return $_[0] if $_[0]->isempty; $_tol = $_[1] if defined $_[1]; my ($min, $max, $tmp); ($min, $max) = $_[0]->slice('(1)')->minmax; return re($_[0])->sever unless (abs($min) > $_tol || abs($max) > $_tol); $_[0]; } =head2 mlog =for ref Return matrix logarithm of a square matrix. =for usage PDL = mlog(PDL(A)) =for example my $a = random(10,10); my $log = mlog($a); =cut *mlog = \&PDL::mlog; sub PDL::mlog { my ($m, $tol) = @_; my @dims = $m->dims; barf("mlog requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); mfun($m, sub{$_[0].=log $_[0]} , 0, $tol); } =head2 msqrt =for ref Return matrix square root (principal) of a square matrix. =for usage PDL = msqrt(PDL(A)) =for example my $a = random(10,10); my $sqrt = msqrt($a); =cut *msqrt = \&PDL::msqrt; sub PDL::msqrt { my ($m, $tol) = @_; my @dims = $m->dims; barf("msqrt requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); $m = $m->r2C unless @dims == 3; my ($t, undef, $z, undef, $info) = $m->mschur(1); if ($info){ warn "msqrt: Can't compute Schur form\n"; return; } ($t, $info) = $t->ctrsqrt(0); if($info){ warn "msqrt: can't compute square root\n"; return; } $m = $z x $t x $z->t(1); return (@dims ==3) ? $m : toreal($m, $tol); } =head2 mexp =for ref Return matrix exponential of a square matrix. =for usage PDL = mexp(PDL(A)) =for example my $a = random(10,10); my $exp = mexp($a); =cut *mexp = \&PDL::mexp; sub PDL::mexp { my ($m, $order, $trace) = @_; my @dims = $m->dims; barf("mexp requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($info, $ns); $info = PDL::null; $ns = PDL::null; $trace = 1 unless defined $trace; $order = 6 unless defined $order; $m = $m->copy; @dims == 3 ? $m->xchg(1,2)->cgeexp($order, 1, $trace, $ns, $info) : $m->xchg(0,1)->geexp($order, 1, $trace, $ns, $info); if ($info){ warn "mexp: Error $info"; } else{ return $m; } } #*mexp2 = \&PDL::mexp2; #sub PDL::mexp2 { # my ($m, $order) = @_; # my @dims = $m->dims; # barf("mexp requires a 2-D square matrix") # unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); # my ($norm, $X, $c, $D, $N, $fact, $cX, $trace); # if (defined $order){ # $order++; # } # else{ # $order = 8; # } # Trace normalization # $m = $m->copy; # $trace = $m->diag->sumover / $m->dim(1); # if (@dims == 3){ # $trace = $trace->im->r2C if ($trace->re < 0); # $m->diagonal(1,2) .= $m->diagonal(1,2) - $trace; # } # elsif ($trace > 0){ # $m->diagonal(0,1) -= $trace; # } # Scale M # $norm = $m->mnorm(0); # $norm = $norm > 0 ? PDL::floor(1 + ($norm->log / log(2))) : 0; # $norm = 0 unless $norm > 0; # $m = $m / 2**$norm if $norm > 0; # $X = $m; # $N = $m / 2; # $D = -$m / 2; # $c = 0.5; # if (@dims == 3){ # $N->re->diagonal(0,1)++; # $D->re->diagonal(0,1)++; # } # else{ # $N->diagonal(0,1)++; # $D->diagonal(0,1)++; # } # # for ($fact = 2; $fact <= $order;$fact++){ # # Padé coeff # $c = $c * ($order - $fact + 1 ) / ($fact * (2 * $order - $fact +1)); # # if (@dims == 3){ # $X = PDL::cmmult($m, $X); # $cX = PDL::Complex::Cmul($X, PDL::Complex::r2C(PDL->pdl($c))); # } # else{ # $X = PDL::mmult($m, $X); # $cX = PDL::mult($X, PDL->pdl($c),0); # } # $N = PDL::plus($N,$cX,0); # $D = ($fact % 2) ? PDL::minus($D,$cX,0) : # PDL::plus($D,$cX,0); # } # # $X = PDL::msolvex($D,$N, equilibrate=>1); # # # Squaring # if($norm > 0){ # for(1..$norm){ # $X x= $X; # } # } # # # Reverse trace normalization # $X = $trace->exp * $X if (@dims == 3 || $trace > 0); # $X; #} *mexpts = \&PDL::mexpts; sub PDL::mexpts { my ($m, $order, $tol) = @_; my @dims = $m->dims; barf("mexp1 requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($em, $trm); $order = 20 unless defined $order; $em = (@dims == 3 ) ? diag(r2C ones($dims[1])) : diag(ones($dims[1])); $trm = $em->copy; for (1..($order - 1)){ $trm = $trm x ($m / $_); $em += $trm; } return (@dims ==3) ? $em : toreal($em, $tol); } =head2 mpow =for ref Return matrix power of a square matrix. =for usage PDL = mpow(PDL(A), SCALAR(exponent)) =for example my $a = random(10,10); my $powered = mpow($a,2.5); =cut #TODO: improve it (really crappy) *mpow = \&PDL::mpow; sub PDL::mpow { my ($m, $power, $tol, $eigen) = @_; my @dims = $m->dims; barf("mpow requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my $ret; if (UNIVERSAL::isa($power,'PDL') and $power->dims > 1){ my ($e, $v) = $m->meigen(0,1); $ret = $v * $e->Cpow($power) x $v->minv; } elsif( 1/$dims[-1] * 1000 > abs($power) and !$eigen){ $ret = $m; my $pow = floor($power); $pow++ if ($power < 0 and $power != $pow); # TODO: what a beautiful thing (is it a game ?) for(my $i = 1; $i < abs($pow); $i++){ $ret x= $m;} $ret = $ret->minv if $power < 0; if ($power = $power - $pow){ if($power == 0.5){ my $v = $m->msqrt; $ret = ($pow == 0) ? $v : $ret x $v; } else{ my ($e, $v) = $m->meigen(0,1); $ret = ($pow == 0) ? ($v * $e**$power x $v->minv) : $ret->r2C x ($v * $e**$power x $v->minv); } } } else{ my ($e, $v) = $m->meigen(0,1); $ret = $v * $e**$power x $v->minv; } return (@dims ==3) ? $ret : toreal($ret, $tol); } =head2 mcos =for ref Return matrix cosine of a square matrix. =for usage PDL = mcos(PDL(A)) =for example my $a = random(10,10); my $cos = mcos($a); =cut *mcos = \&PDL::mcos; sub PDL::mcos { my $m = shift; my @dims = $m->dims; barf("mcos requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return (@dims == 3) ? (mexp(i*$m) + mexp(- i*$m)) / 2 : re(mexp(i*$m))->sever; } =head2 macos =for ref Return matrix inverse cosine of a square matrix. =for usage PDL = macos(PDL(A)) =for example my $a = random(10,10); my $acos = macos($a); =cut *macos = \&PDL::macos; sub PDL::macos { my ($m, $tol) = @_; my @dims = $m->dims; barf("macos requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($id, $ret); $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $ret = i * mlog( ($m->r2C - i * msqrt( ($id - $m x $m), $tol))); return (@dims ==3) ? $ret : toreal($ret, $tol); } =head2 msin =for ref Return matrix sine of a square matrix. =for usage PDL = msin(PDL(A)) =for example my $a = random(10,10); my $sin = msin($a); =cut *msin = \&PDL::msin; sub PDL::msin { my $m = shift; my @dims = $m->dims; barf("msin requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return (@dims == 3) ? (mexp(i*$m) - mexp(- i*$m))/(2*i) : im(mexp(i*$m))->sever; } =head2 masin =for ref Return matrix inverse sine of a square matrix. =for usage PDL = masin(PDL(A)) =for example my $a = random(10,10); my $asin = masin($a); =cut *masin = \&PDL::masin; sub PDL::masin { my ($m, $tol) = @_; my @dims = $m->dims; barf("masin requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($ret, $id); $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $ret = (- i) * mlog(((i*$m) + msqrt($id - $m x $m, $tol))); return (@dims ==3) ? $ret : toreal($ret, $tol); } =head2 mtan =for ref Return matrix tangent of a square matrix. =for usage PDL = mtan(PDL(A)) =for example my $a = random(10,10); my $tan = mtan($a); =cut *mtan = \&PDL::mtan; sub PDL::mtan { my ($m, $id) = @_; my @dims = $m->dims; barf("mtan requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return scalar msolvex(mcos($m), msin($m),equilibrate=>1) unless $id; if (@dims == 3){ $id = PDL::zeroes $m; $id->slice('(0),:,:')->diagonal(0,1) .= 1; $m = mexp(-2*i*$m); return scalar msolvex( ($id + $m ),( (- i) * ($id - $m)),equilibrate=>1); } else{ $m = mexp(i * $m); return scalar $m->re->msolvex($m->im,equilibrate=>1); } } =head2 matan =for ref Return matrix inverse tangent of a square matrix. =for usage PDL = matan(PDL(A)) =for example my $a = random(10,10); my $atan = matan($a); =cut *matan = \&PDL::matan; sub PDL::matan { my ($m, $tol) = @_; my @dims = $m->dims; barf("matan requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($id, $ret); $id = PDL::zeroes($m)->r2C; $id->re->diagonal(0,1) .= 1; $ret = - i/2 * mlog( scalar PDL::msolvex( ($id - i*$m) ,($id + i*$m),equilibrate=>1 )); return (@dims ==3) ? $ret : toreal($ret, $tol); } =head2 mcot =for ref Return matrix cotangent of a square matrix. =for usage PDL = mcot(PDL(A)) =for example my $a = random(10,10); my $cot = mcot($a); =cut *mcot = \&PDL::mcot; sub PDL::mcot { my ($m, $id) = @_; my @dims = $m->dims; barf("mcot requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return scalar msolvex(msin($m),mcos($m),equilibrate=>1) unless $id; if (@dims == 3){ $id = PDL::zeroes $m; $id->slice('(0),:,:')->diagonal(0,1) .= 1; $m = mexp(-2*i*$m); return scalar msolvex( ($id - $m ),( i * ($id + $m)),equilibrate=>1); } else{ $m = mexp(i * $m); return scalar $m->im->msolvex($m->re,equilibrate=>1); } } =head2 macot =for ref Return matrix inverse cotangent of a square matrix. =for usage PDL = macot(PDL(A)) =for example my $a = random(10,10); my $acot = macot($a); =cut *macot = \&PDL::macot; sub PDL::macot { my ($m, $tol, $id) = @_; my @dims = $m->dims; barf("macot requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "macot: singular matrix"; return; } return matan($inv,$tol); } =head2 msec =for ref Return matrix secant of a square matrix. =for usage PDL = msec(PDL(A)) =for example my $a = random(10,10); my $sec = msec($a); =cut *msec = \&PDL::msec; sub PDL::msec { my $m = shift; my @dims = $m->dims; barf("msec requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return (@dims == 3) ? PDL::minv(mexp(i+$m) + mexp(- i*$m)) * 2 : scalar PDL::minv(re(mexp(i*$m))); } =head2 masec =for ref Return matrix inverse secant of a square matrix. =for usage PDL = masec(PDL(A)) =for example my $a = random(10,10); my $asec = masec($a); =cut *masec = \&PDL::masec; sub PDL::masec { my ($m, $tol) = @_; my @dims = $m->dims; barf("masec requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "masec: singular matrix"; return; } return macos($inv,$tol); } =head2 mcsc =for ref Return matrix cosecant of a square matrix. =for usage PDL = mcsc(PDL(A)) =for example my $a = random(10,10); my $csc = mcsc($a); =cut *mcsc = \&PDL::mcsc; sub PDL::mcsc { my $m = shift; my @dims = $m->dims; barf("mcsc requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return (@dims == 3) ? PDL::minv(mexp(i*$m) - mexp(- i*$m)) * 2*i : scalar PDL::minv(im(mexp(i*$m))); } =head2 macsc =for ref Return matrix inverse cosecant of a square matrix. =for usage PDL = macsc(PDL(A)) =for example my $a = random(10,10); my $acsc = macsc($a); =cut *macsc = \&PDL::macsc; sub PDL::macsc { my ($m, $tol) = @_; my @dims = $m->dims; barf("macsc requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "macsc: singular matrix"; return; } return masin($inv,$tol); } =head2 mcosh =for ref Return matrix hyperbolic cosine of a square matrix. =for usage PDL = mcosh(PDL(A)) =for example my $a = random(10,10); my $cos = mcosh($a); =cut *mcosh = \&PDL::mcosh; sub PDL::mcosh { my $m = shift; my @dims = $m->dims; barf("mcosh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); ( $m->mexp + mexp(-$m) )/2; } =head2 macosh =for ref Return matrix hyperbolic inverse cosine of a square matrix. =for usage PDL = macosh(PDL(A)) =for example my $a = random(10,10); my $acos = macosh($a); =cut *macosh = \&PDL::macosh; sub PDL::macosh { my ($m, $tol) = @_; my @dims = $m->dims; barf("macosh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($id, $ret); $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $ret = msqrt($m x $m - $id); $m = $m->r2C if $ret->getndims > @dims; mlog($m + $ret, $tol); } =head2 msinh =for ref Return matrix hyperbolic sine of a square matrix. =for usage PDL = msinh(PDL(A)) =for example my $a = random(10,10); my $sinh = msinh($a); =cut *msinh = \&PDL::msinh; sub PDL::msinh { my $m = shift; my @dims = $m->dims; barf("msinh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); ( $m->mexp - mexp(-$m) )/2; } =head2 masinh =for ref Return matrix hyperbolic inverse sine of a square matrix. =for usage PDL = masinh(PDL(A)) =for example my $a = random(10,10); my $asinh = masinh($a); =cut *masinh = \&PDL::masinh; sub PDL::masinh { my ($m, $tol) = @_; my @dims = $m->dims; barf("masinh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($id, $ret); $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $ret = msqrt($m x $m + $id); $m = $m->r2C if $ret->getndims > @dims; mlog(($m + $ret), $tol); } =head2 mtanh =for ref Return matrix hyperbolic tangent of a square matrix. =for usage PDL = mtanh(PDL(A)) =for example my $a = random(10,10); my $tanh = mtanh($a); =cut *mtanh = \&PDL::mtanh; sub PDL::mtanh { my ($m, $id) = @_; my @dims = $m->dims; barf("mtanh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return scalar msolvex(mcosh($m), msinh($m),equilibrate=>1) unless $id; $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $m = mexp(-2*$m); return scalar msolvex( ($id + $m ),($id - $m), equilibrate=>1); } =head2 matanh =for ref Return matrix hyperbolic inverse tangent of a square matrix. =for usage PDL = matanh(PDL(A)) =for example my $a = random(10,10); my $atanh = matanh($a); =cut *matanh = \&PDL::matanh; sub PDL::matanh { my ($m, $tol) = @_; my @dims = $m->dims; barf("matanh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($id, $ret); $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; mlog( scalar msolvex( ($id - $m ),($id + $m),equilibrate=>1), $tol ) / 2; } =head2 mcoth =for ref Return matrix hyperbolic cotangent of a square matrix. =for usage PDL = mcoth(PDL(A)) =for example my $a = random(10,10); my $coth = mcoth($a); =cut *mcoth = \&PDL::mcoth; sub PDL::mcoth { my ($m, $id) = @_; my @dims = $m->dims; barf("mcoth requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); scalar msolvex(msinh($m), mcosh($m),equilibrate=>1) unless $id; $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $m = mexp(-2*$m); return scalar msolvex( ($id - $m ),($id + $m),equilibrate=>1); } =head2 macoth =for ref Return matrix hyperbolic inverse cotangent of a square matrix. =for usage PDL = macoth(PDL(A)) =for example my $a = random(10,10); my $acoth = macoth($a); =cut *macoth = \&PDL::macoth; sub PDL::macoth { my ($m, $tol) = @_; my @dims = $m->dims; barf("macoth requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "macoth: singular matrix"; return; } return matanh($inv,$tol); } =head2 msech =for ref Return matrix hyperbolic secant of a square matrix. =for usage PDL = msech(PDL(A)) =for example my $a = random(10,10); my $sech = msech($a); =cut *msech = \&PDL::msech; sub PDL::msech { my $m = shift; my @dims = $m->dims; barf("msech requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); PDL::minv( $m->mexp + mexp(-$m) ) * 2; } =head2 masech =for ref Return matrix hyperbolic inverse secant of a square matrix. =for usage PDL = masech(PDL(A)) =for example my $a = random(10,10); my $asech = masech($a); =cut *masech = \&PDL::masech; sub PDL::masech { my ($m, $tol) = @_; my @dims = $m->dims; barf("masech requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "masech: singular matrix"; return; } return macosh($inv,$tol); } =head2 mcsch =for ref Return matrix hyperbolic cosecant of a square matrix. =for usage PDL = mcsch(PDL(A)) =for example my $a = random(10,10); my $csch = mcsch($a); =cut *mcsch = \&PDL::mcsch; sub PDL::mcsch { my $m = shift; my @dims = $m->dims; barf("mcsch requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); PDL::minv( $m->mexp - mexp(-$m) ) * 2; } =head2 macsch =for ref Return matrix hyperbolic inverse cosecant of a square matrix. =for usage PDL = macsch(PDL(A)) =for example my $a = random(10,10); my $acsch = macsch($a); =cut *macsch = \&PDL::macsch; sub PDL::macsch { my ($m, $tol) = @_; my @dims = $m->dims; barf("macsch requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "macsch: singular matrix"; return; } return masinh($inv,$tol); } =head2 mfun =for ref Return matrix function of second argument of a square matrix. Function will be applied on a PDL::Complex object. =for usage PDL = mfun(PDL(A),'cos') =for example my $a = random(10,10); my $fun = mfun($a,'cos'); sub sinbycos2{ $_[0]->set_inplace(0); $_[0] .= $_[0]->Csin/$_[0]->Ccos**2; } # Try diagonalization $fun = mfun($a, \&sinbycos2,1); # Now try Schur/Parlett $fun = mfun($a, \&sinbycos2); # Now with function. scalar msolve($a->mcos->mpow(2), $a->msin); =cut *mfun = \&PDL::mfun; sub PDL::mfun { my ($m, $method, $diag, $tol) = @_; my @dims = $m->dims; barf("mfun requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); if ($diag){ my ($e, $v, $inv, $info); ($e, $v) = $m->meigen(0,1); ($inv, $info) = $v->minv; unless ($info){ $method = 'PDL::Complex::'.$method unless ref($method); eval {$v = ($v * $e->$method) x $v->minv;}; if ($@){ warn "mfun: Error $@\n"; return; } } else{ warn "mfun: Non invertible matrix in computation of $method\n"; return; } return (@dims ==3) ? $v : toreal($v, $tol); } else{ $m = $m->r2C unless @dims == 3; my ($t, undef, $z, undef, $info) = $m->mschur(1); if ($info){ warn "mfun: Can't compute Schur form\n"; return; } $method = 'PDL::Complex::'.$method unless ref($method); ($t, $info) = $t->ctrfun(0,$method); if($info){ warn "mfun: Can't compute $method\n"; return; } $m = $z x $t x $z->t(1); return (@dims ==3) ? $m : toreal($m, $tol); } } #*mspfun = \&PDL::mspfun; #sub PDL::mspfun { # my ($m, $method, $tol) = @_; # my @dims = $m->dims; # barf("mspfun requires a 2-D square matrix") # unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); # my ($T, $Z, $F, $p, $i, $j, $sden, $s ); # ($T, undef, $Z) = $m->r2C->mschur(1); # $F = $T->diagonal(1,2)->$method->diag; # for $p (1..($dims[-1] - 1 )){ # for $i (0..($dims[-1]-$p-1)){ # $j = $i + $p; # $s = $T(,($j),($i))->Cmul($F(,($j),($j))->Csub($F(,($i),($i)))); # if ($i < ($j-1)){ # $s = $s + $T(,$i+1:$j-1,($i))->cdot(1, $F(,($j), $i+1:$j-1),1)->Csub($F(,$i+1:$j-1,($i))->cdot(1,$T(,($j), $i+1:$j-1),1)); # } # $sden = $T(,($j),($j))->Csub($T(,($i),($i))); # if ($sden != 0){ # $s = $s / $sden; # } # else{ # barf "Illegal division by zero occured\n"; # } # $F(,($j),($i)) .= $s; # } # } # print $F; # $m = $Z x $F x $Z->t(1); # return (@dims ==3) ? $m : toreal($m, $tol); # #} =head1 TODO Improve error return and check singularity. Improve (msqrt,mlog) / r2C =head1 AUTHOR Copyright (C) Grégory Vanuxem 2005-2007. This library is free software; you can redistribute it and/or modify it under the terms of the artistic license as specified in the Artistic file. =cut ; # Exit with OK status 1; PDL-LinearAlgebra-0.12/LinearAlgebra.pm0000644113142400244210000055721012535324046022023 0ustar chris.h.marshallDomain Userspackage PDL::LinearAlgebra; use PDL::Ops; use PDL::Core; use PDL::Basic qw/sequence/; use PDL::Primitive qw/which which_both/; use PDL::Ufunc qw/sumover/; use PDL::NiceSlice; use PDL::Slices; use PDL::Complex; use PDL::LinearAlgebra::Real; use PDL::LinearAlgebra::Complex; use PDL::LinearAlgebra::Special qw//; use PDL::Exporter; no warnings 'uninitialized'; use constant{ NO => 0, WARN => 1, BARF => 2, }; use strict; our $VERSION = '0.12'; $VERSION = eval $VERSION; @PDL::LinearAlgebra::ISA = qw/PDL::Exporter/; @PDL::LinearAlgebra::EXPORT_OK = qw/t diag issym minv mtriinv msyminv mposinv mdet mposdet mrcond positivise mdsvd msvd mgsvd mlu mhessen mchol mqr mql mlq mrq meigen meigenx mgeigen mgeigenx msymeigen msymeigenx msymgeigen msymgeigenx msolve mtrisolve msymsolve mpossolve msolvex msymsolvex mpossolvex mrank mlls mllsy mllss mglm mlse tritosym mnorm mgschur mgschurx mcrossprod mcond morth mschur mschurx posinf neginf nan NO WARN BARF setlaerror getlaerorr laerror/; %PDL::LinearAlgebra::EXPORT_TAGS = (Func=>[@PDL::LinearAlgebra::EXPORT_OK]); my $_laerror = BARF; my $nan; BEGIN { $nan = 0/pdl(0) } sub nan() { $nan->copy }; my $posinf; BEGIN { $posinf = 1/pdl(0) } sub posinf() { $posinf->copy }; my $neginf; BEGIN { $neginf = -1/pdl(0) } sub neginf() { $neginf->copy }; { package # hide from CPAN indexer PDL::Complex; use PDL::Types; use vars qw($sep $sep2); our $floatformat = "%4.4g"; # Default print format for long numbers our $doubleformat = "%6.6g"; *r2p = \&PDL::Complex::Cr2p; *p2r = \&PDL::Complex::Cp2r; *scale = \&PDL::Complex::Cscale; *conj = \&PDL::Complex::Cconj; *abs2 = \&PDL::Complex::Cabs2; *arg = \&PDL::Complex::Carg; *tan = \&PDL::Complex::Ctan; *proj = \&PDL::Complex::Cproj; *asin = \&PDL::Complex::Casin; *acos = \&PDL::Complex::Cacos; *atan = \&PDL::Complex::Catan; *sinh = \&PDL::Complex::Csinh; *cosh = \&PDL::Complex::Ccosh; *tanh = \&PDL::Complex::Ctanh; *asinh = \&PDL::Complex::Casinh; *acosh = \&PDL::Complex::Cacosh; *atanh = \&PDL::Complex::Catanh; *prodover = \&PDL::Complex::Cprodover; sub ecplx { my ($re, $im) = @_; return $re if UNIVERSAL::isa($re,'PDL::Complex'); if (defined $im){ $re = pdl($re) unless (UNIVERSAL::isa($re,'PDL')); $im = pdl($im) unless (UNIVERSAL::isa($im,'PDL')); my $ret = PDL::new_from_specification('PDL::Complex', $re->type, 2, $re->dims); $ret->slice('(0),') .= $re; $ret->slice('(1),') .= $im; return $ret; } croak "first dimsize must be 2" unless $re->dims > 0 && $re->dim(0) == 2; bless $_[0]->slice(''); } sub sumover { my $c = shift; return dims($c) > 1 ? PDL::Ufunc::sumover($c->xchg(0,1)) : $c; } sub norm { my ($m, $real, $trans) = @_; # If trans == true => transpose output matrice # If real == true => rotate (complex as a vector) # such that max abs will be real #require PDL::LinearAlgebra::Complex; PDL::LinearAlgebra::Complex::cnrm2($m,1, my $ret = null); if ($real){ my ($index, $scale); $m = PDL::Complex::Cscale($m,1/$ret->dummy(0))->reshape(-1); $index = $m->Cabs->maximum_ind; $scale = $m->mv(0,-1)->index($index)->mv(-1,0); $scale= $scale->Cconj/$scale->Cabs; return $trans ? $m->xchg(1,2)*$scale->dummy(2) : $m*$scale->dummy(2)->xchg(1,2); } return $trans ? PDL::Complex::Cscale($m->xchg(1,2),1/$ret->dummy(0)->xchg(0,1))->reshape(-1) : PDL::Complex::Cscale($m,1/$ret->dummy(0))->reshape(-1); } } ######################################################################## =encoding Latin-1 =head1 NAME PDL::LinearAlgebra - Linear Algebra utils for PDL =head1 SYNOPSIS use PDL::LinearAlgebra; $a = random (100,100); ($U, $s, $V) = mdsvd($a); =head1 DESCRIPTION This module provides a convenient interface to L and L. Its primary purpose is educational. You have to know that routines defined here are not optimized, particularly in term of memory. Since Blas and Lapack use a column major ordering scheme some routines here need to transpose matrices before calling fortran routines and transpose back (see the documentation of each routine). If you need optimized code use directly L and L. It's planned to "port" this module to PDL::Matrix such that transpositions will not be necessary, the major problem is that two new modules need to be created PDL::Matrix::Real and PDL::Matrix::Complex. =cut =head1 FUNCTIONS =head2 setlaerror =for ref Sets action type when an error is encountered, returns previous type. Available values are NO, WARN and BARF (predefined constants). If, for example, in computation of the inverse, singularity is detected, the routine can silently return values from computation (see manuals), warn about singularity or barf. BARF is the default value. =for example # h : x -> g(f(x)) $a = sequence(5,5); $err = setlaerror(NO); ($b, $info)= f($a); setlaerror($err); $info ? barf "can't compute h" : return g($b); =cut sub setlaerror($){ my $err = $_laerror; $_laerror = shift; $err; } =head2 getlaerror =for ref Gets action type when an error is encountered. 0 => NO, 1 => WARN, 2 => BARF =cut sub getlaerror{ $_laerror; } sub laerror{ return unless $_laerror; if ($_laerror < 2){ warn "$_[0]\n"; } else{ barf "$_[0]\n"; } } =head2 t =for usage PDL = t(PDL, SCALAR(conj)) conj : Conjugate Transpose = 1 | Transpose = 0, default = 1; =for ref Convenient function for transposing real or complex 2D array(s). For PDL::Complex, if conj is true returns conjugate transposed array(s) and doesn't support dataflow. Supports threading. =cut sub t{ my $m = shift; $m->t(@_); } sub PDL::t { $_[0]->xchg(0,1); } sub PDL::Complex::t { my ($m, $conj) = @_; $conj = 1 unless defined($conj); $conj ? PDL::Complex::Cconj($m->xchg(1,2)) : $m->xchg(1,2); } =head2 issym =for usage PDL = issym(PDL, SCALAR|PDL(tol),SCALAR(hermitian)) tol : tolerance value, default: 1e-8 for double else 1e-5 hermitian : Hermitian = 1 | Symmetric = 0, default = 1; =for ref Checks symmetricity/Hermitianicity of matrix. Supports threading. =cut sub issym{ my $m = shift; $m->issym(@_); } sub PDL::issym { my ($m, $tol) = @_; my @dims = $m->dims; barf("issym: Require square array(s)") if( $dims[0] != $dims[1] ); $tol = defined($tol) ? $tol : ($m->type == double) ? 1e-8 : 1e-5; my ($min,$max) = PDL::Ufunc::minmaximum($m - $m->xchg(0,1)); $min = $min->minimum; $max = $max->maximum; return (((abs($max) > $tol) + (abs($min) > $tol)) == 0); } sub PDL::Complex::issym { my ($m, $tol, $conj) = @_; my @dims = $m->dims; barf("issym: Require square array(s)") if( $dims[1] != $dims[2] ); $conj = 1 unless defined($conj); $tol = defined($tol) ? $tol : ($m->type == double) ? 1e-8 : 1e-5; my ($min, $max, $mini, $maxi); if ($conj){ ($min,$max) = PDL::Ufunc::minmaximum(PDL::clump($m - $m->t(1),2)); } else{ ($min,$max) = PDL::Ufunc::minmaximum(PDL::clump($m - $m->xchg(1,2),2)); } $min->minimum($mini = null); $max->maximum($maxi = null); return (((abs($maxi) > $tol) + (abs($mini) > $tol)) == 0); } =head2 diag =for ref Returns i-th diagonal if matrix in entry or matrix with i-th diagonal with entry. I-th diagonal returned flows data back&forth. Can be used as lvalue subs if your perl supports it. Supports threading. =for usage PDL = diag(PDL, SCALAR(i), SCALAR(vector))) i : i-th diagonal, default = 0 vector : create diagonal matrices by threading over row vectors, default = 0 =for example my $a = random(5,5); my $diag = diag($a,2); # If your perl support lvaluable subroutines. $a->diag(-2) .= pdl(1,2,3); # Construct a (5,5,5) PDL (5 matrices) with # diagonals from row vectors of $a $a->diag(0,1) =cut sub diag{ my $m = shift; $m->diag(@_); } sub PDL::diag{ my ($a,$i, $vec) = @_; my ($diag, $dim, @dims, $z); @dims = $a->dims; $diag = ($i < 0) ? -$i : $i ; if (@dims == 1 || $vec){ $dim = $dims[0]; my $zz = $dim + $diag; $z= PDL::zeroes('PDL',$a->type,$zz, $zz,@dims[1..$#dims]); if ($i){ ($i < 0) ? $z(:($dim-1),$diag:)->diagonal(0,1) .= $a : $z($diag:,:($dim-1))->diagonal(0,1).=$a; } else{ $z->diagonal(0,1) .= $a; } } elsif($i < 0){ $z = $a(:-$diag-1 , $diag:)->diagonal(0,1); } elsif($i){ $z = $a($diag:, :-$diag-1)->diagonal(0,1); } else{$z = $a->diagonal(0,1);} $z; } sub PDL::Complex::diag{ my ($a,$i, $vec) = @_; my ($diag, $dim, @dims, $z); @dims = $a->dims; $diag = ($i < 0) ? -$i : $i ; if (@dims == 2 || $vec){ $dim = $dims[1]; my $zz = $dim + $diag; $z= PDL::zeroes('PDL::Complex',$a->type, 2, $zz, $zz,@dims[2..$#dims]); if ($i){ ($i < 0) ? $z(,:($dim-1),$diag:)->diagonal(1,2) .= $a : $z(,$diag:,:($dim-1))->diagonal(1,2).=$a; } else{ $z->diagonal(1,2) .= $a; } } elsif($i < 0){ $z = $a(,:-$diag-1 , $diag:)->diagonal(1,2); } elsif($i){ $z = $a(,$diag:, :-$diag-1 )->diagonal(1,2); } else{ $z = $a->diagonal(1,2); } $z; } if ($^V and $^V ge v5.6.0){ use attributes 'PDL', \&PDL::diag, 'lvalue'; use attributes 'PDL', \&PDL::Complex::diag, 'lvalue'; } =head2 tritosym =for ref Returns symmetric or Hermitian matrix from lower or upper triangular matrix. Supports inplace and threading. Uses L or L from Lapack. =for usage PDL = tritosym(PDL, SCALAR(uplo), SCALAR(conj)) uplo : UPPER = 0 | LOWER = 1, default = 0 conj : Hermitian = 1 | Symmetric = 0, default = 1; =for example # Assume $a is symmetric triangular my $a = random(10,10); my $b = tritosym($a); =cut sub tritosym{ my $m = shift; $m->tritosym(@_); } sub PDL::tritosym { my ($m, $upper) = @_; my @dims = $m->dims; barf("tritosym: Require square array(s)") unless( $dims[0] == $dims[1] ); my $b = $m->is_inplace ? $m : PDL::new_from_specification(ref($m),$m->type,@dims); $m->tricpy($upper, $b) unless $m->is_inplace(0); $m->tricpy($upper, $b->xchg(0,1)); $b; } sub PDL::Complex::tritosym { my ($m, $upper, $conj) = @_; my @dims = $m->dims; barf("tritosym: Require square array(s)") if( $dims[1] != $dims[2] ); my $b = $m->is_inplace ? $m : PDL::new_from_specification(ref($m),$m->type,@dims); $conj = 1 unless defined($conj); $conj ? PDL::Complex::Cconj($m)->ctricpy($upper, $b->xchg(1,2)) : $m->ctricpy($upper, $b->xchg(1,2)); # ... $m->ctricpy($upper, $b) unless (!$conj && $m->is_inplace(0)); $b((1),)->diagonal(0,1) .= 0 if $conj; $b; } =head2 positivise =for ref Returns entry pdl with changed sign by row so that average of positive sign > 0. In other words threads among dimension 1 and row = -row if sum(sign(row)) < 0. Works inplace. =for example my $a = random(10,10); $a -= 0.5; $a->xchg(0,1)->inplace->positivise; =cut *positivise = \&PDL::positivise; sub PDL::positivise{ my $m = shift; my $tmp; $m = $m->copy unless $m->is_inplace(0); $tmp = $m->dice('X', which(( $m->lt(0,0)->sumover > ($m->dim(0)/2))>0)); $tmp->inplace->mult(-1,0);# .= -$tmp; $m; } =head2 mcrossprod =for ref Computes the cross-product of two matrix: A' x B. If only one matrix is given, takes B to be the same as A. Supports threading. Uses L or L. =for usage PDL = mcrossprod(PDL(A), (PDL(B)) =for example my $a = random(10,10); my $crossproduct = mcrossprod($a); =cut sub mcrossprod{ my $m = shift; $m->mcrossprod(@_); } sub PDL::mcrossprod { my($a, $b) = @_; my(@dims) = $a->dims; barf("mcrossprod: Require 2D array(s)") unless( @dims >= 2 ); $b = $a unless defined $b; $a->crossprod($b); } sub PDL::Complex::mcrossprod { my($a, $b) = @_; my(@dims) = $a->dims; barf("mcrossprod: Require 2D array(s)") unless( @dims >= 3); $b = $a unless defined $b; $a->ccrossprod($b); } =head2 mrank =for ref Computes the rank of a matrix, using a singular value decomposition. from Lapack. =for usage SCALAR = mrank(PDL, SCALAR(TOL)) TOL: tolerance value, default : mnorm(dims(PDL),'inf') * mnorm(PDL) * EPS =for example my $a = random(10,10); my $b = mrank($a, 1e-5); =cut *mrank = \&PDL::mrank; sub PDL::mrank { my($m, $tol) = @_; my(@dims) = $m->dims; barf("mrank: Require a 2D matrix") unless( @dims == 2 or @dims == 3 ); my ($sv, $info, $err); $err = setlaerror(NO); # Sometimes mdsvd bugs for float (SGEBRD) # ($sv, $info) = $m->msvd(0, 0); ($sv, $info) = $m->mdsvd(0); setlaerror($err); barf("mrank: SVD algorithm did not converge\n") if $info; unless (defined $tol){ $tol = ($dims[-1] > $dims[-2] ? $dims[-1] : $dims[-2]) * $sv((0)) * lamch(pdl($m->type,3)); } (which($sv > $tol))->dim(0); } =head2 mnorm =for ref Computes norm of real or complex matrix Supports threading. =for usage PDL(norm) = mnorm(PDL, SCALAR(ord)); ord : 0|'inf' : Infinity norm 1|'one' : One norm 2|'two' : norm 2 (default) 3|'fro' : frobenius norm =for example my $a = random(10,10); my $norm = mnorm($a); =cut sub mnorm { my $m =shift; $m->mnorm(@_); } sub PDL::mnorm { my ($m, $ord) = @_; $ord = 2 unless (defined $ord); if ($ord eq 'inf'){ $ord = 0; } elsif ($ord eq 'one'){ $ord = 1; } elsif($ord eq 'two'){ $ord = 2; } elsif($ord eq 'fro'){ $ord = 3; } if ($ord == 0){ $m->lange(1); } elsif($ord == 1){ $m->lange(2); } elsif($ord == 3){ $m->lange(3); } else{ my ($sv, $info, $err); $err = setlaerror(NO); ($sv, $info) = $m->msvd(0, 0); setlaerror($err); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mnorm: SVD algorithm did not converge for matrix (PDL(s) @list): \$info = $info"); } $sv->slice('(0)')->reshape(-1)->sever; } } sub PDL::Complex::mnorm { my ($m, $ord) = @_; $ord = 2 unless (defined $ord); if ($ord eq 'inf'){ $ord = 0; } elsif ($ord eq 'one'){ $ord = 1; } elsif($ord eq 'two'){ $ord = 2; } elsif($ord eq 'fro'){ $ord = 3; } if ($ord == 0){ return bless $m->clange(1),'PDL'; } elsif($ord == 1){ return bless $m->clange(2),'PDL'; } elsif($ord == 3){ return bless $m->clange(3),'PDL'; } else{ my ($sv, $info, $err) ; $err = setlaerror(NO); ($sv, $info) = $m->msvd(0, 0); setlaerror($err); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mnorm: SVD algorithm did not converge for matrix (PDL(s) @list): \$info = $info"); } $sv->slice('(0)')->reshape(-1)->sever; } } =head2 mdet =for ref Computes determinant of a general square matrix using LU factorization. Supports threading. Uses L or L from Lapack. =for usage PDL(determinant) = mdet(PDL); =for example my $a = random(10,10); my $det = mdet($a); =cut sub mdet{ my $m =shift; $m->mdet; } sub PDL::mdet { my $m = shift; my @dims = $m->dims; barf("mdet: Require square array(s)") unless( $dims[0] == $dims[1] && @dims >= 2); my ($info, $ipiv); $m = $m->copy(); $info = null; $ipiv = null; $m->getrf($ipiv, $info); $m = $m->diagonal(0,1)->prodover; $m = $m * ((PDL::Ufunc::sumover(sequence($ipiv->dim(0))->plus(1,0) != $ipiv)%2)*(-2)+1) ; $info = $m->flat->index(which($info != 0 )); $info .= 0 unless $info->isempty; $m; } sub PDL::Complex::mdet { my $m = shift; my @dims = $m->dims; barf("mdet: Require square array(s)") unless( @dims >= 3 && $dims[1] == $dims[2] ); my ($info, $ipiv); $m = $m->copy(); $info = null; $ipiv = null; $m->cgetrf($ipiv, $info); $m = PDL::Complex::Cprodover($m->diagonal(1,2)); $m = $m * ((PDL::Ufunc::sumover(sequence($ipiv->dim(0))->plus(1,0) != $ipiv)%2)*(-2)+1) ; $info = which($info != 0 ); unless ($info->isempty){ $m->re->flat->index($info) .= 0; $m->im->flat->index($info) .= 0; } $m; } =head2 mposdet =for ref Compute determinant of a symmetric or Hermitian positive definite square matrix using Cholesky factorization. Supports threading. Uses L or L from Lapack. =for usage (PDL, PDL) = mposdet(PDL, SCALAR) SCALAR : UPPER = 0 | LOWER = 1, default = 0 =for example my $a = random(10,10); my $det = mposdet($a); =cut sub mposdet{ my $m =shift; $m->mposdet(@_); } sub PDL::mposdet { my ($m, $upper) = @_; my @dims = $m->dims; barf("mposdet: Require square array(s)") unless( @dims >= 2 && $dims[0] == $dims[1] ); $m = $m->copy(); $m->potrf($upper, (my $info=null)); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mposdet: Matrix (PDL(s) @list) is/are not positive definite(s) (after potrf factorization): \$info = $info"); } $m = $m->diagonal(0,1)->prodover->pow(2); return wantarray ? ($m, $info) : $m; } sub PDL::Complex::mposdet { my ($m, $upper) = @_; my @dims = $m->dims; barf("mposdet: Require square array(s)") unless( @dims >= 3 && $dims[1] == $dims[2] ); $m = $m->copy(); $m->cpotrf($upper, (my $info=null)); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mposdet: Matrix (PDL(s) @list) is/are not positive definite(s) (after cpotrf factorization): \$info = $info"); } $m = PDL::Complex::re($m)->diagonal(0,1)->prodover->pow(2); return wantarray ? ($m, $info) : $m; } =head2 mcond =for ref Computes the condition number (two-norm) of a general matrix. The condition number in two-n is defined: norm (a) * norm (inv (a)). Uses a singular value decomposition. Supports threading. =for usage PDL = mcond(PDL) =for example my $a = random(10,10); my $cond = mcond($a); =cut sub mcond{ my $m =shift; $m->mcond(@_); } sub PDL::mcond { my $m = shift; my @dims = $m->dims; barf("mcond: Require 2D array(s)") unless( @dims >= 2 ); my ($sv, $info, $err, $ret, $temp); $err = setlaerror(NO); ($sv, $info) = $m->msvd(0, 0); setlaerror($err); if($info->max > 0) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; barf("mcond: Algorithm did not converge for matrix (PDL(s) @list): \$info = $info"); } $temp = $sv->slice('(0)'); $ret = $temp/$sv->((-1)); $info = $ret->flat->index(which($temp == 0)); $info .= posinf unless $info->isempty; return $ret; } sub PDL::Complex::mcond { my $m = shift; my @dims = $m->dims; barf("mcond: Require 2D array(s)") unless( @dims >= 3); my ($sv, $info, $err, $ret, $temp) ; $err = setlaerror(NO); ($sv, $info) = $m->msvd(0, 0); setlaerror($err); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mcond: Algorithm did not converge for matrix (PDL(s) @list): \$info = $info"); } $temp = $sv->slice('(0)'); $ret = $temp/$sv->((-1)); $info = $ret->flat->index(which($temp == 0)); $info .= posinf unless $info->isempty; return $ret; } =head2 mrcond =for ref Estimates the reciprocal condition number of a general square matrix using LU factorization in either the 1-norm or the infinity-norm. The reciprocal condition number is defined: 1/(norm (a) * norm (inv (a))) Supports threading. Works on transposed array(s) =for usage PDL = mrcond(PDL, SCALAR(ord)) ord : 0 : Infinity norm (default) 1 : One norm =for example my $a = random(10,10); my $rcond = mrcond($a,1); =cut sub mrcond{ my $m =shift; $m->mcond(@_); } sub PDL::mrcond { my ($m,$anorm) = @_; $anorm = 0 unless defined $anorm; my @dims = $m->dims; barf("mrcond: Require square array") unless ( $dims[0] == $dims[1] ); my ($ipiv, $info,$rcond,$norm); $norm = $m->mnorm($anorm); $m = $m->xchg(0,1)->copy(); $ipiv = PDL->null; $info = PDL->null; $rcond = PDL->null; $m->getrf($ipiv, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mrcond: Factor(s) U (PDL(s) @list) is/are singular(s) (after getrf factorization): \$info = $info"); } else{ $m->gecon($anorm,$norm,$rcond,$info); } return wantarray ? ($rcond, $info) : $rcond; } sub PDL::Complex::mrcond { my ($m, $anorm) = @_; $anorm = 0 unless defined $anorm; my @dims = $m->dims; barf("mrcond: Require square array(s)") unless ( $dims[1] == $dims[2] ); my ($ipiv, $info,$rcond,$norm); $norm = $m->mnorm($anorm); $m = $m->xchg(1,2)->copy(); $ipiv = PDL->null; $info = PDL->null; $rcond = PDL->null; $m->cgetrf($ipiv, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mrcond: Factor(s) U (PDL(s) @list) is/are singular(s) (after cgetrf factorization) : \$info = $info"); } else{ $m->cgecon($anorm,$norm,$rcond,$info); } return wantarray ? ($rcond, $info) : $rcond; } =head2 morth =for ref Returns an orthonormal basis of the range space of matrix A. =for usage PDL = morth(PDL(A), SCALAR(tol)) tol : tolerance for determining rank, default: 1e-8 for double else 1e-5 =for example my $a = sequence(10,10); my $ortho = morth($a, 1e-8); =cut *morth = \&PDL::morth; sub PDL::morth { my ($m, $tol) = @_; my @dims = $m->dims; barf("morth: Require a matrix") unless( (@dims == 2) || (@dims == 3)); my ($u, $s, $rank, $info, $err); $tol = (defined $tol) ? $tol : ($m->type == double) ? 1e-8 : 1e-5; $err = setlaerror(NO); ($u, $s, undef, $info) = $m->mdsvd; setlaerror($err); barf("morth: SVD algorithm did not converge\n") if $info; $rank = (which($s > $tol))->dim(0) - 1; if(@dims == 3){ return $rank < 0 ? PDL::Complex->null : $u(,:$rank,)->sever; } else{ return $rank < 0 ? null : $u(:$rank,)->sever; } } =head2 mnull =for ref Returns an orthonormal basis of the null space of matrix A. Works on transposed array. =for usage PDL = mnull(PDL(A), SCALAR(tol)) tol : tolerance for determining rank, default: 1e-8 for double else 1e-5 =for example my $a = sequence(10,10); my $null = mnull($a, 1e-8); =cut *mnull = \&PDL::mnull; sub PDL::mnull { my ($m, $tol) = @_; my @dims = $m->dims; barf("mnull: Require a matrix") unless( (@dims == 2) || (@dims == 3)); my ($v, $s, $rank, $info, $err); $tol = (defined $tol) ? $tol : ($m->type == double) ? 1e-8 : 1e-5; $err = setlaerror(NO); (undef, $s, $v, $info) = $m->mdsvd; setlaerror($err); barf("mnull: SVD algorithm did not converge\n") if $info; #TODO: USE TRANSPOSED A $rank = (which($s > $tol))->dim(0); if (@dims == 3){ return $rank < $dims[1] ? $v->(,,$rank:)->t : PDL::Complex->null; } else{ return $rank < $dims[1] ? $v->xchg(0,1)->($rank:,)->sever : null; } } =head2 minv =for ref Computes inverse of a general square matrix using LU factorization. Supports inplace and threading. Uses L and L or L and L from Lapack and returns C in array context. =for usage PDL(inv) = minv(PDL) =for example my $a = random(10,10); my $inv = minv($a); =cut sub minv($) { $_[0]->minv; } sub PDL::minv { my $m = shift; my @dims = $m->dims; my ($ipiv, $info); barf("minv: Require square array(s)") if( $dims[0] != $dims[1] ); $m = $m->copy() unless $m->is_inplace(0); $ipiv = PDL->null; $info = PDL->null; $m->getrf($ipiv, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("minv: Factor(s) U (PDL(s) @list) is/are singular(s) (after getrf factorization): \$info = $info"); } $m->getri($ipiv,$info); return wantarray ? ($m, $info) : $m; } sub PDL::Complex::minv { my $m = shift; my @dims = $m->dims; my ($ipiv, $info); barf("minv: Require square array(s)") if( $dims[1] != $dims[2] ); $m = $m->copy() unless $m->is_inplace(0); $ipiv = PDL->null; $info = PDL->null; $m->cgetrf($ipiv, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("minv: Factor(s) U (PDL(s) @list) is/are singular(s) (after cgetrf factorization) : \$info = $info"); } else{ $m->cgetri($ipiv,$info); } return wantarray ? ($m, $info) : $m; } =head2 mtriinv =for ref Computes inverse of a triangular matrix. Supports inplace and threading. Uses L or L from Lapack. Returns C in array context. =for usage (PDL, PDL(info))) = mtriinv(PDL, SCALAR(uplo), SCALAR|PDL(diag)) uplo : UPPER = 0 | LOWER = 1, default = 0 diag : UNITARY DIAGONAL = 1, default = 0 =for example # Assume $a is upper triangular my $a = random(10,10); my $inv = mtriinv($a); =cut sub mtriinv{ my $m = shift; $m->mtriinv(@_); } sub PDL::mtriinv{ my $m = shift; my $upper = @_ ? (1 - shift) : pdl (long,1); my $diag = shift; my(@dims) = $m->dims; barf("mtriinv: Require square array(s)") if( $dims[0] != $dims[1] ); $m = $m->copy() unless $m->is_inplace(0); my $info = PDL->null; $m->trtri($upper, $diag, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mtriinv: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } return wantarray ? ($m, $info) : $m; } sub PDL::Complex::mtriinv{ my $m = shift; my $upper = @_ ? (1 - shift) : pdl (long,1); my $diag = shift; my(@dims) = $m->dims; barf("mtriinv: Require square array(s)") if( $dims[1] != $dims[2] ); $m = $m->copy() unless $m->is_inplace(0); my $info = PDL->null; $m->ctrtri($upper, $diag, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mtriinv: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } return wantarray ? ($m, $info) : $m; } =head2 msyminv =for ref Computes inverse of a symmetric square matrix using the Bunch-Kaufman diagonal pivoting method. Supports inplace and threading. Uses L and L or L and L from Lapack and returns C in array context. =for usage (PDL, (PDL(info))) = msyminv(PDL, SCALAR|PDL(uplo)) uplo : UPPER = 0 | LOWER = 1, default = 0 =for example # Assume $a is symmetric my $a = random(10,10); my $inv = msyminv($a); =cut sub msyminv { my $m = shift; $m->msyminv(@_); } sub PDL::msyminv { my $m = shift; my $upper = @_ ? (1 - shift) : pdl (long,1); my ($ipiv , $info); my(@dims) = $m->dims; barf("msyminv: Require square array(s)") if( $dims[0] != $dims[1] ); $m = $m->copy() unless $m->is_inplace(0); $ipiv = zeroes(long, @dims[1..$#dims]); @dims = @dims[2..$#dims]; $info = @dims ? zeroes(long,@dims) : pdl(long,0); $m->sytrf($upper, $ipiv, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msyminv: Block diagonal matrix D (PDL(s) @list) is/are singular(s) (after sytrf factorization): \$info = $info"); } else{ $m->sytri($upper,$ipiv,$info); $m = $m->t->tritosym($upper); } return wantarray ? ($m, $info) : $m; } sub PDL::Complex::msyminv { my $m = shift; my $upper = @_ ? (1 - shift) : pdl (long,1); my ($ipiv , $info); my(@dims) = $m->dims; barf("msyminv: Require square array(s)") if( $dims[1] != $dims[2] ); $m = $m->copy() unless $m->is_inplace(0); $ipiv = zeroes(long, @dims[2..$#dims]); @dims = @dims[3..$#dims]; $info = @dims ? zeroes(long,@dims) : pdl(long,0); $m->csytrf($upper, $ipiv, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msyminv: Block diagonal matrix D (PDL(s) @list) is/are singular(s) (after csytrf factorization): \$info = $info"); } else{ $m->csytri($upper,$ipiv,$info); $m = $m->xchg(1,2)->tritosym($upper, 0); } return wantarray ? ($m, $info) : $m; } =head2 mposinv =for ref Computes inverse of a symmetric positive definite square matrix using Cholesky factorization. Supports inplace and threading. Uses L and L or L and L from Lapack and returns C in array context. =for usage (PDL, (PDL(info))) = mposinv(PDL, SCALAR|PDL(uplo)) uplo : UPPER = 0 | LOWER = 1, default = 0 =for example # Assume $a is symmetric positive definite my $a = random(10,10); $a = $a->crossprod($a); my $inv = mposinv($a); =cut sub mposinv { my $m = shift; $m->mposinv(@_); } sub PDL::mposinv { my $m = shift; my $upper = @_ ? (1 - shift) : pdl (long,1); my(@dims) = $m->dims; barf("mposinv: Require square array(s)") unless( $dims[0] == $dims[1] ); $m = $m->copy() unless $m->is_inplace(0); @dims = @dims[2..$#dims]; my $info = @dims ? zeroes(long,@dims) : pdl(long,0); $m->potrf($upper, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mposinv: matrix (PDL(s) @list) is/are not positive definite(s) (after potrf factorization): \$info = $info"); } else{ $m->potri($upper, $info); } return wantarray ? ($m, $info) : $m; } sub PDL::Complex::mposinv { my $m = shift; my $upper = @_ ? (1 - shift) : pdl (long,1); my(@dims) = $m->dims; barf("mposinv: Require square array(s)") unless( $dims[1] == $dims[2] ); $m = $m->copy() unless $m->is_inplace(0); @dims = @dims[3..$#dims]; my $info = @dims ? zeroes(long,@dims) : pdl(long,0); $m->cpotrf($upper, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mposinv: matrix (PDL(s) @list) is/are not positive definite(s) (after cpotrf factorization): \$info = $info"); } else{ $m->cpotri($upper, $info); } return wantarray ? ($m, $info) : $m; } =head2 mpinv =for ref Computes pseudo-inverse (Moore-Penrose) of a general matrix. Works on transposed array. =for usage PDL(pseudo-inv) = mpinv(PDL, SCALAR(tol)) TOL: tolerance value, default : mnorm(dims(PDL),'inf') * mnorm(PDL) * EPS =for example my $a = random(5,10); my $inv = mpinv($a); =cut *mpinv = \&PDL::mpinv; sub PDL::mpinv{ my ($m, $tol) = @_; my @dims = $m->dims; barf("mpinv: Require a matrix") unless( @dims == 2 or @dims == 3 ); my ($ind, $cind, $u, $s, $v, $info, $err); $err = setlaerror(NO); #TODO: don't transpose ($u, $s, $v, $info) = $m->mdsvd(2); setlaerror($err); laerror("mpinv: SVD algorithm did not converge\n") if $info; unless (defined $tol){ $tol = ($dims[-1] > $dims[-2] ? $dims[-1] : $dims[-2]) * $s((0)) * lamch(pdl($m->type,3)); } ($ind, $cind) = which_both( $s > $tol ); $s->index($cind) .= 0 if defined $cind; $s->index($ind) .= 1/$s->index($ind) ; $ind = (@dims == 3) ? ($v->t * $s->r2C ) x $u->t : ($v->xchg(0,1) * $s ) x $u->xchg(0,1); return wantarray ? ($ind, $info) : $ind; } =head2 mlu =for ref Computes LU factorization. Uses L or L from Lapack and returns L, U, pivot and info. Works on transposed array. =for usage (PDL(l), PDL(u), PDL(pivot), PDL(info)) = mlu(PDL) =for example my $a = random(10,10); ($l, $u, $pivot, $info) = mlu($a); =cut *mlu = \&PDL::mlu; sub PDL::mlu { my $m = shift; my(@dims) = $m->dims; barf("mlu: Require a matrix") unless((@dims == 2) || (@dims == 3)); my ($ipiv, $info, $l, $u); $m = $m->copy; $info = pdl(long ,0); $ipiv = zeroes(long, ($dims[-2] > $dims[-1] ? $dims[-1]: $dims[-2])); if (@dims == 3){ $m->t->cgetrf($ipiv,$info); if($info > 0) { $info--; laerror("mlu: Factor U is singular: U($info,$info) = 0 (after cgetrf factorization)"); $u = $l = $m; } else{ $u = $m->mtri; $l = $m->mtri(1); if ($dims[-1] > $dims[-2]){ $u = $u(,,:($dims[0]-1)); $l((0), :($dims[0]-1), :($dims[0]-1))->diagonal(0,1) .= 1; $l((1), :($dims[0]-1), :($dims[0]-1))->diagonal(0,1) .= 0; } elsif($dims[-1] < $dims[-2]){ $l = $l(,:($dims[1]-1),); $l((0),,)->diagonal(0,1).=1; $l((1),,)->diagonal(0,1).=0; } else{ $l((0),,)->diagonal(0,1).=1; $l((1),,)->diagonal(0,1).=0; } } } else{ $m->t->getrf($ipiv,$info); if($info > 0) { $info--; laerror("mlu: Factor U is singular: U($info,$info) = 0 (after getrf factorization)"); $u = $l = $m; } else{ $u = $m->mtri; $l = $m->mtri(1); if ($dims[1] > $dims[0]){ $u = $u(,:($dims[0]-1))->sever; $l( :($dims[0]-1), :($dims[0]-1))->diagonal(0,1) .= 1; } elsif($dims[1] < $dims[0]){ $l = $l(:($dims[1]-1),)->sever; $l->diagonal(0,1) .= 1; } else{ $l->diagonal(0,1).=1; } } } $l, $u, $ipiv, $info; } =head2 mchol =for ref Computes Cholesky decomposition of a symmetric matrix also knows as symmetric square root. If inplace flag is set, overwrite the leading upper or lower triangular part of A else returns triangular matrix. Returns C in array context. Supports threading. Uses L or L from Lapack. =for usage PDL(Cholesky) = mchol(PDL, SCALAR) SCALAR : UPPER = 0 | LOWER = 1, default = 0 =for example my $a = random(10,10); $a = crossprod($a, $a); my $u = mchol($a); =cut sub mchol { my $m = shift; $m->mchol(@_); } sub PDL::mchol { my($m, $upper) = @_; my(@dims) = $m->dims; barf("mchol: Require square array(s)") if ( $dims[0] != $dims[1] ); my ($uplo, $info); $m = $m->mtri($upper) unless $m->is_inplace(0); @dims = @dims[2..$#dims]; $info = @dims ? zeroes(long,@dims) : pdl(long,0); $uplo = 1 - $upper; $m->potrf($uplo,$info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mchol: matrix (PDL(s) @list) is/are not positive definite(s) (after potrf factorization): \$info = $info"); } return wantarray ? ($m, $info) : $m; } sub PDL::Complex::mchol { my($m, $upper) = @_; my(@dims) = $m->dims; barf("mchol: Require square array(s)") if ( $dims[1] != $dims[2] ); my ($uplo, $info); $m = $m->mtri($upper) unless $m->is_inplace(0); @dims = @dims[3..$#dims]; $info = @dims ? zeroes(long,@dims) : pdl(long,0); $uplo = 1 - $upper; $m->cpotrf($uplo,$info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mchol: matrix (PDL(s) @list) is/are not positive definite(s) (after cpotrf factorization): \$info = $info"); } return wantarray ? ($m, $info) : $m; } =head2 mhessen =for ref Reduces a square matrix to Hessenberg form H and orthogonal matrix Q. It reduces a general matrix A to upper Hessenberg form H by an orthogonal similarity transformation: Q' x A x Q = H or A = Q x H x Q' Uses L and L or L and L from Lapack and returns C in scalar context else C and C. Works on transposed array. =for usage (PDL(h), (PDL(q))) = mhessen(PDL) =for example my $a = random(10,10); ($h, $q) = mhessen($a); =cut *mhessen = \&PDL::mhessen; sub PDL::mhessen { my $m = shift; my(@dims) = $m->dims; barf("mhessen: Require a square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($info, $tau, $h, $q); $m = $m->t->copy; $info = pdl(long, 0); if(@dims == 3){ $tau = zeroes($m->type, 2, ($dims[-2]-1)); $m->cgehrd(1,$dims[-2],$tau,$info); if (wantarray){ $q = $m->copy; $q->cunghr(1, $dims[-2], $tau, $info); } $m = $m->xchg(1,2); $h = $m->mtri; $h((0),:-2, 1:)->diagonal(0,1) .= $m((0),:-2, 1:)->diagonal(0,1); $h((1),:-2, 1:)->diagonal(0,1) .= $m((1),:-2, 1:)->diagonal(0,1); } else{ $tau = zeroes($m->type, ($dims[0]-1)); $m->gehrd(1,$dims[0],$tau,$info); if (wantarray){ $q = $m->copy; $q->orghr(1, $dims[0], $tau, $info); } $m = $m->xchg(0,1); $h = $m->mtri; $h(:-2, 1:)->diagonal(0,1) .= $m(:-2, 1:)->diagonal(0,1); } wantarray ? return ($h, $q->xchg(-2,-1)->sever) : $h; } =head2 mschur =for ref Computes Schur form, works inplace. A = Z x T x Z' Supports threading for unordered eigenvalues. Uses L or L from Lapack and returns schur(T) in scalar context. Works on tranposed array(s). =for usage ( PDL(schur), (PDL(eigenvalues), (PDL(left schur vectors), PDL(right schur vectors), $sdim), $info) ) = mschur(PDL(A), SCALAR(schur vector),SCALAR(left eigenvector), SCALAR(right eigenvector),SCALAR(select_func), SCALAR(backtransform), SCALAR(norm)) schur vector : Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 left eigenvector : Left eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 right eigenvector : Right eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 select_func : Select_func is used to select eigenvalues to sort to the top left of the Schur form. An eigenvalue is selected if PerlInt select_func(PDL::Complex(w)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func(PDL::Complex(w)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned). All eigenvalues/vectors are selected if select_func is undefined. backtransform : Whether or not backtransforms eigenvectors to those of A. Only supported if schur vectors are computed, default = 1. norm : Whether or not computed eigenvectors are normalized to have Euclidean norm equal to 1 and largest component real, default = 1 Returned values : Schur form T (SCALAR CONTEXT), eigenvalues, Schur vectors (Z) if requested, left eigenvectors if requested right eigenvectors if requested sdim: Number of eigenvalues selected if select_func is defined. info: Info output from gees/cgees. =for example my $a = random(10,10); my $schur = mschur($a); sub select{ my $m = shift; # select "discrete time" eigenspace return $m->Cabs < 1 ? 1 : 0; } my ($schur,$eigen, $svectors,$evectors) = mschur($a,1,1,0,\&select); =cut sub mschur{ my $m = shift; $m->mschur(@_); } sub PDL::mschur{ my ($m, $jobv, $jobvl, $jobvr, $select_func, $mult,$norm) = @_; my(@dims) = $m->dims; barf("mschur: Require square array(s)") unless($dims[0] == $dims[1]); barf("mschur: thread doesn't supported for selected vectors") if ($select_func && @dims > 2 && ($jobv == 2 || $jobvl == 2 || $jobvr == 2)); my ($w, $v, $info, $type, $select,$sdim, $vr,$vl, $mm, @ret, $select_f, $wi, $wtmp); $mult = 1 unless defined($mult); $norm = 1 unless defined($norm); $jobv = $jobvl = $jobvr = 0 unless wantarray; $type = $m->type; $select = $select_func ? pdl(long,1) : pdl(long,0); $info = null; $sdim = null; $wtmp = null; $wi = null; $mm = $m->is_inplace ? $m->xchg(0,1) : $m->xchg(0,1)->copy; if ($select_func){ $select_f= sub{ &$select_func(PDL::Complex::complex(pdl($type,@_[0..1]))); }; } $v = $jobv ? PDL::new_from_specification('PDL', $type, $dims[1], $dims[1],@dims[2..$#dims]) : pdl($type,0); $mm->gees( $jobv, $select, $wtmp, $wi, $v, $sdim,$info, $select_f); if ($info->max > 0 && $_laerror){ my ($index, @list); $index = which((($info > 0)+($info <=$dims[0]))==2); unless ($index->isempty){ @list = $index->list; laerror("mschur: The QR algorithm failed to converge for matrix (PDL(s) @list): \$info = $info"); print ("Returning converged eigenvalues\n"); } if ($select_func){ $index = which((($info > 0)+($info == ($dims[0]+1) ))==2); unless ($index->isempty){ @list = $index->list; laerror("mschur: The eigenvalues could not be reordered because some\n". "eigenvalues were too close to separate (the problem". "is very ill-conditioned) for PDL(s) @list: \$info = $info"); } $index = which((($info > 0)+($info > ($dims[0]+1) ))==2); unless ($index->isempty){ @list = $index->list; warn("mschur: The Schur form no longer satisfy select_func = 1\n because of roundoff". "or underflow (PDL(s) @list)\n"); } } } if ($select_func){ if ($jobvl == 2){ if(!$sdim){ push @ret, PDL::Complex->null; $jobvl = 0; } } if ($jobvr == 2){ if(!$sdim){ push @ret, PDL::Complex->null; $jobvr = 0; } } push @ret, $sdim; } if ($jobvl || $jobvr){ my ($sel, $job, $wtmpi, $wtmpr, $sdims); unless ($jobvr && $jobvl){ $job = $jobvl ? 2 : 1; } if ($select_func){ if ($jobvl == 1 || $jobvr == 1 || $mult){ $sdims = null; if ($jobv){ $vr = $v->copy if $jobvr; $vl = $v->copy if $jobvl; } else{ $vr = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1],@dims[2..$#dims]) if $jobvr; $vl = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1],@dims[2..$#dims]) if $jobvl; $mult = 0; } $mm->trevc($job, $mult, $sel, $vl, $vr, $sdims, my $infos=null); if ($jobvr){ if($norm){ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); bless $vr, 'PDL::Complex'; unshift @ret, $jobvr == 2 ? $vr(,,:($sdim-1))->norm(1,1) : $vr->norm(1,1); } else{ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; unshift @ret, $jobvr == 2 ? $vr(,:($sdim-1))->sever : $vr; } } if ($jobvl){ if($norm){ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); bless $vl, 'PDL::Complex'; unshift @ret, $jobvl == 2 ? $vl(,,:($sdim-1))->norm(1,1) : $vl->norm(1,1); } else{ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; unshift @ret, $jobvl == 2 ? $vl(,:($sdim-1))->sever : $vl; } } } else{ $vr = PDL::new_from_specification('PDL', $type, $dims[1], $sdim) if $jobvr; $vl = PDL::new_from_specification('PDL', $type, $dims[1], $sdim) if $jobvl; $sel = zeroes($dims[1]); $sel(:($sdim-1)) .= 1; $mm->trevc($job, 2, $sel, $vl, $vr, $sdim, my $infos = null); $wtmpr = $wtmp(:($sdim-1)); $wtmpi = $wi(:($sdim-1)); if ($jobvr){ if ($norm){ (undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr,1); bless $vr, 'PDL::Complex'; unshift @ret, $vr->norm(1,1); } else{ (undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; unshift @ret,$vr; } } if ($jobvl){ if ($norm){ (undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl,1); bless $vl, 'PDL::Complex'; unshift @ret, $vl->norm(1,1); } else{ (undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; unshift @ret, $vl; } } } } else{ if ($jobv){ $vr = $v->copy if $jobvr; $vl = $v->copy if $jobvl; } else{ $vr = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1],@dims[2..$#dims]) if $jobvr; $vl = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1],@dims[2..$#dims]) if $jobvl; $mult = 0; } $mm->trevc($job, $mult, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvr){ if ($norm){ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); bless $vr, 'PDL::Complex'; unshift @ret, $vr->norm(1,1); } else{ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; unshift @ret, $vr; } } if ($jobvl){ if ($norm){ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); bless $vl, 'PDL::Complex'; unshift @ret, $vl->norm(1,1); } else{ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; unshift @ret, $vl; } } } } $w = PDL::Complex::ecplx ($wtmp, $wi); if ($jobv == 2 && $select_func) { $v = $sdim > 0 ? $v->xchg(0,1)->(:($sdim-1),)->sever : null; unshift @ret,$v; } elsif($jobv){ $v = $v->xchg(0,1)->sever; unshift @ret,$v; } $m = $mm->xchg(0,1)->sever unless $m->is_inplace(0); return wantarray ? ($m, $w, @ret, $info) : $m; } sub PDL::Complex::mschur { my($m, $jobv, $jobvl, $jobvr, $select_func, $mult, $norm) = @_; my(@dims) = $m->dims; barf("mschur: Require square array(s)") unless($dims[1] == $dims[2]); barf("mschur: thread doesn't supported for selected vectors") if ($select_func && @dims > 3 && ($jobv == 2 || $jobvl == 2 || $jobvr == 2)); my ($w, $v, $info, $type, $select,$sdim, $vr,$vl, $mm, @ret); $mult = 1 unless defined($mult); $norm = 1 unless defined($norm); $jobv = $jobvl = $jobvr = 0 unless wantarray; $type = $m->type; $select = $select_func ? pdl(long,1) : pdl(long,0); $info = null; $sdim = null; $mm = $m->is_inplace ? $m->xchg(1,2) : $m->xchg(1,2)->copy; $w = PDL::Complex->null; $v = $jobv ? PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1],@dims[3..$#dims]) : pdl($type,[0,0]); $mm->cgees( $jobv, $select, $w, $v, $sdim, $info, $select_func); if ($info->max > 0 && $_laerror){ my ($index, @list); $index = which((($info > 0)+($info <=$dims[1]))==2); unless ($index->isempty){ @list = $index->list; laerror("mschur: The QR algorithm failed to converge for matrix (PDL(s) @list): \$info = $info"); print ("Returning converged eigenvalues\n"); } if ($select_func){ $index = which((($info > 0)+($info == ($dims[1]+1) ))==2); unless ($index->isempty){ @list = $index->list; laerror("mschur: The eigenvalues could not be reordered because some\n". "eigenvalues were too close to separate (the problem". "is very ill-conditioned) for PDL(s) @list: \$info = $info"); } $index = which((($info > 0)+($info > ($dims[1]+1) ))==2); unless ($index->isempty){ @list = $index->list; warn("mschur: The Schur form no longer satisfy select_func = 1\n because of roundoff". "or underflow (PDL(s) @list)\n"); } } } if ($select_func){ if ($jobvl == 2){ if (!$sdim){ push @ret, PDL::Complex->null; $jobvl = 0; } } if ($jobvr == 2){ if (!$sdim){ push @ret, PDL::Complex->null; $jobvr = 0; } } push @ret, $sdim; } if ($jobvl || $jobvr){ my ($sel, $job, $sdims); unless ($jobvr && $jobvl){ $job = $jobvl ? 2 : 1; } if ($select_func){ if ($jobvl == 1 || $jobvr == 1 || $mult){ $sdims = null; if ($jobv){ $vr = $v->copy if $jobvr; $vl = $v->copy if $jobvl; } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1],@dims[3..$#dims]) if $jobvr; $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1],@dims[3..$#dims]) if $jobvl; $mult = 0; } $mm->ctrevc($job, $mult, $sel, $vl, $vr, $sdims, my $infos=null); if ($jobvr){ if ($jobvr == 2){ unshift @ret, $norm ? $vr(,,:($sdim-1))->norm(1,1) : $vr(,,:($sdim-1))->xchg(1,2)->sever; } else{ unshift @ret, $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; } } if ($jobvl){ if ($jobvl == 2){ unshift @ret, $norm ? $vl(,,:($sdim-1))->norm(1,1) : $vl(,,:($sdim-1))->xchg(1,2)->sever; } else{ unshift @ret, $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; } } } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2,$dims[1], $sdim) if $jobvr; $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $sdim) if $jobvl; $sel = zeroes($dims[1]); $sel(:($sdim-1)) .= 1; $mm->ctrevc($job, 2, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvr){ unshift @ret, $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; } if ($jobvl){ unshift @ret, $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; } } } else{ if ($jobv){ $vr = $v->copy if $jobvr; $vl = $v->copy if $jobvl; } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1],@dims[3..$#dims]) if $jobvr; $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1],@dims[3..$#dims]) if $jobvl; $mult = 0; } $mm->ctrevc($job, $mult, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvl){ push @ret, $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; } if ($jobvr){ push @ret, $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; } } } if ($jobv == 2 && $select_func) { $v = $sdim > 0 ? $v->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; unshift @ret,$v; } elsif($jobv){ $v = $v->xchg(1,2)->sever; unshift @ret,$v; } $m = $mm->xchg(1,2)->sever unless $m->is_inplace(0); return wantarray ? ($m, $w, @ret, $info) : $m; } =head2 mschurx =for ref Computes Schur form, works inplace. Uses L or L from Lapack and returns schur(T) in scalar context. Works on transposed array. =for usage ( PDL(schur) (,PDL(eigenvalues)) (, PDL(schur vectors), HASH(result)) ) = mschurx(PDL, SCALAR(schur vector), SCALAR(left eigenvector), SCALAR(right eigenvector),SCALAR(select_func), SCALAR(sense), SCALAR(backtransform), SCALAR(norm)) schur vector : Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 left eigenvector : Left eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 right eigenvector : Right eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 select_func : Select_func is used to select eigenvalues to sort to the top left of the Schur form. An eigenvalue is selected if PerlInt select_func(PDL::Complex(w)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func(PDL::Complex(w)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned). All eigenvalues/vectors are selected if select_func is undefined. sense : Determines which reciprocal condition numbers will be computed. 0: None are computed 1: Computed for average of selected eigenvalues only 2: Computed for selected right invariant subspace only 3: Computed for both If select_func is undefined, sense is not used. backtransform : Whether or not backtransforms eigenvectors to those of A. Only supported if schur vector are computed, default = 1 norm : Whether or not computed eigenvectors are normalized to have Euclidean norm equal to 1 and largest component real, default = 1 Returned values : Schur form T (SCALAR CONTEXT), eigenvalues, Schur vectors if requested, HASH{VL}: left eigenvectors if requested HASH{VR}: right eigenvectors if requested HASH{info}: info output from gees/cgees. if select_func is defined: HASH{n}: number of eigenvalues selected, HASH{rconde}: reciprocal condition numbers for the average of the selected eigenvalues if requested, HASH{rcondv}: reciprocal condition numbers for the selected right invariant subspace if requested. =for example my $a = random(10,10); my $schur = mschurx($a); sub select{ my $m = shift; # select "discrete time" eigenspace return $m->Cabs < 1 ? 1 : 0; } my ($schur,$eigen, $vectors,%ret) = mschurx($a,1,0,0,\&select); =cut *mschurx = \&PDL::mschurx; sub PDL::mschurx{ my($m, $jobv, $jobvl, $jobvr, $select_func, $sense, $mult,$norm) = @_; my(@dims) = $m->dims; barf("mschur: Require a square matrix") unless( ( (@dims == 2)|| (@dims == 3) )&& $dims[-1] == $dims[-2]); my ($w, $v, $info, $type, $select, $sdim, $rconde, $rcondv, %ret, $mm, $vl, $vr); $mult = 1 unless defined($mult); $norm = 1 unless defined($norm); $jobv = $jobvl = $jobvr = 0 unless wantarray; $type = $m->type; if ($select_func){ $select = pdl(long 1); } else{ $select = pdl(long,0); $sense = pdl(long,0); } $info = null; $sdim = null; $rconde = null; $rcondv = null; $mm = $m->is_inplace ? $m->xchg(-1,-2) : $m->xchg(-1,-2)->copy; if (@dims == 3){ $w = PDL::Complex->null; $v = $jobv ? PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]) : pdl($type,[0,0]); $mm->cgeesx( $jobv, $select, $sense, $w, $v, $sdim, $rconde, $rcondv,$info, $select_func); if ($info){ if ($info < $dims[1]){ laerror("mschurx: The QR algorithm failed to converge"); print ("Returning converged eigenvalues\n") if $_laerror; } laerror("mschurx: The eigenvalues could not be reordered because some\n". "eigenvalues were too close to separate (the problem". "is very ill-conditioned)") if $info == ($dims[1] + 1); warn("mschurx: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n") if ($info > ($dims[1] + 1) and $_laerror); } if ($select_func){ if(!$sdim){ if ($jobvl == 2){ $ret{VL} = PDL::Complex->null; $jobvl = 0; } if ($jobvr == 2){ $ret{VR} = PDL::Complex->null; $jobvr = 0; } } $ret{n} = $sdim; } if ($jobvl || $jobvr){ my ($sel, $job, $sdims); unless ($jobvr && $jobvl){ $job = $jobvl ? 2 : 1; } if ($select_func){ if ($jobvl == 1 || $jobvr == 1 || $mult){ $sdims = null; if ($jobv){ $vr = $v->copy if $jobvr; $vl = $v->copy if $jobvl; } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]) if $jobvr; $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]) if $jobvl; $mult = 0; } $mm->ctrevc($job, $mult, $sel, $vl, $vr, $sdims, my $infos=null); if ($jobvr){ if ($jobvr == 2){ $ret{VR} = $norm ? $vr(,,:($sdim-1))->norm(1,1) : $vr(,,:($sdim-1))->xchg(1,2)->sever; } else{ $ret{VR} = $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; } } if ($jobvl){ if ($jobvl == 2){ $ret{VL} = $norm ? $vl(,,:($sdim-1))->norm(1,1) : $vl(,,:($sdim-1))->xchg(1,2)->sever; } else{ $ret{VL} = $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; } } } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2,$dims[1], $sdim) if $jobvr; $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $sdim) if $jobvl; $sel = zeroes($dims[1]); $sel(:($sdim-1)) .= 1; $mm->ctrevc($job, 2, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvr){ $ret{VL} = $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; } if ($jobvl){ $ret{VL} = $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; } } } else{ if ($jobv){ $vr = $v->copy if $jobvr; $vl = $v->copy if $jobvl; } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]) if $jobvr; $vl = PDL::new_from_specification('PDL::Complex', $type, $dims[1], 2, $dims[1]) if $jobvl; $mult = 0; } $mm->ctrevc($job, $mult, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvl){ $ret{VL} = $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; } if ($jobvr){ $ret{VR} = $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; } } } if ($jobv == 2 && $select_func) { $v = $sdim > 0 ? $v->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; } elsif($jobv){ $v = $v->xchg(1,2)->sever; } } else{ my ($select_f, $wi, $wtmp); if ($select_func){ no strict 'refs'; $select_f= sub{ &$select_func(PDL::Complex::complex(pdl($type,$_[0],$_[1]))); }; } $wi = null; $wtmp = null; $v = $jobv ? PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) : pdl($type,0); $mm->geesx( $jobv, $select, $sense, $wtmp, $wi, $v, $sdim, $rconde, $rcondv,$info, $select_f); if ($info){ if ($info < $dims[0]){ laerror("mschurx: The QR algorithm failed to converge"); print ("Returning converged eigenvalues\n") if $_laerror; } laerror("mschurx: The eigenvalues could not be reordered because some\n". "eigenvalues were too close to separate (the problem". "is very ill-conditioned)") if $info == ($dims[0] + 1); warn("mschurx: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n") if ($info > ($dims[0] + 1) and $_laerror); } if ($select_func){ if(!$sdim){ if ($jobvl == 2){ $ret{VL} = null; $jobvl = 0; } if ($jobvr == 2){ $ret{VR} = null; $jobvr = 0; } } $ret{n} = $sdim; } if ($jobvl || $jobvr){ my ($sel, $job, $wtmpi, $wtmpr, $sdims); unless ($jobvr && $jobvl){ $job = $jobvl ? 2 : 1; } if ($select_func){ if ($jobvl == 1 || $jobvr == 1 || $mult){ $sdims = null; if ($jobv){ $vr = $v->copy if $jobvr; $vl = $v->copy if $jobvl; } else{ $vr = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) if $jobvr; $vl = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) if $jobvl; $mult = 0; } $mm->trevc($job, $mult, $sel, $vl, $vr, $sdims, my $infos=null); if ($jobvr){ if($norm){ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); bless $vr, 'PDL::Complex'; $ret{VR} = $jobvr == 2 ? $vr(,,:($sdim-1))->norm(1,1) : $vr->norm(1,1); } else{ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; $ret{VR} = $jobvr == 2 ? $vr(,:($sdim-1))->sever : $vr; } } if ($jobvl){ if($norm){ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); bless $vl, 'PDL::Complex'; $ret{VL}= $jobvl == 2 ? $vl(,,:($sdim-1))->norm(1,1) : $vl->norm(1,1); } else{ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; $ret{VL}= $jobvl == 2 ? $vl(,:($sdim-1))->sever : $vl; } } } else{ $vr = PDL::new_from_specification('PDL', $type, $dims[1], $sdim) if $jobvr; $vl = PDL::new_from_specification('PDL', $type, $dims[1], $sdim) if $jobvl; $sel = zeroes($dims[1]); $sel(:($sdim-1)) .= 1; $mm->trevc($job, 2, $sel, $vl, $vr, $sdim, my $infos = null); $wtmpr = $wtmp(:($sdim-1)); $wtmpi = $wi(:($sdim-1)); if ($jobvr){ if ($norm){ (undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr,1); bless $vr, 'PDL::Complex'; $ret{VR} = $vr->norm(1,1); } else{ (undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; $ret{VR} = $vr; } } if ($jobvl){ if ($norm){ (undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl,1); bless $vl, 'PDL::Complex'; $ret{VL} = $vl->norm(1,1); } else{ (undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; $ret{VL} = $vl; } } } } else{ if ($jobv){ $vr = $v->copy if $jobvr; $vl = $v->copy if $jobvl; } else{ $vr = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) if $jobvr; $vl = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) if $jobvl; $mult = 0; } $mm->trevc($job, $mult, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvr){ if ($norm){ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); bless $vr, 'PDL::Complex'; $ret{VR} = $vr->norm(1,1); } else{ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; $ret{VR} = $vr; } } if ($jobvl){ if ($norm){ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); bless $vl, 'PDL::Complex'; $ret{VL} = $vl->norm(1,1); } else{ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; $ret{VL} = $vl; } } } } $w = PDL::Complex::ecplx ($wtmp, $wi); if ($jobv == 2 && $select_func) { $v = $sdim > 0 ? $v->xchg(0,1)->(:($sdim-1),) ->sever : null; } elsif($jobv){ $v = $v->xchg(0,1)->sever; } } $ret{info} = $info; if ($sense){ if ($sense == 3){ $ret{rconde} = $rconde; $ret{rcondv} = $rcondv; } else{ $ret{rconde} = $rconde if ($sense == 1); $ret{rcondv} = $rcondv if ($sense == 2); } } $m = $mm->xchg(-1,-2)->sever unless $m->is_inplace(0); return wantarray ? $jobv ? ($m, $w, $v, %ret) : ($m, $w, %ret) : $m; } # scale by max(abs(real)+abs(imag)) sub magn_norm{ my ($m, $trans) = @_; # If trans == true => transpose output matrice my $ret = PDL::abs($m); bless $ret,'PDL'; $ret = PDL::sumover($ret)->maximum; return $trans ? PDL::Complex::Cscale($m->xchg(1,2),1/$ret->dummy(0)->xchg(0,1))->reshape(-1) : PDL::Complex::Cscale($m,1/$ret->dummy(0))->reshape(-1); } #TODO: inplace ? =head2 mgschur =for ref Computes generalized Schur decomposition of the pair (A,B). A = Q x S x Z' B = Q x T x Z' Uses L or L from Lapack. Works on transposed array. =for usage ( PDL(schur S), PDL(schur T), PDL(alpha), PDL(beta), HASH{result}) = mgschur(PDL(A), PDL(B), SCALAR(left schur vector),SCALAR(right schur vector),SCALAR(left eigenvector), SCALAR(right eigenvector), SCALAR(select_func), SCALAR(backtransform), SCALAR(scale)) left schur vector : Left Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 right schur vector : Right Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 left eigenvector : Left eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 right eigenvector : Right eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 select_func : Select_func is used to select eigenvalues to sort. to the top left of the Schur form. An eigenvalue w = wr(j)+sqrt(-1)*wi(j) is selected if PerlInt select_func(PDL::Complex(alpha),PDL | PDL::Complex (beta)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned). All eigenvalues/vectors are selected if select_func is undefined. backtransform : Whether or not backtransforms eigenvectors to those of (A,B). Only supported if right and/or left schur vector are computed, scale : Whether or not computed eigenvectors are scaled so the largest component will have abs(real part) + abs(imag. part) = 1, default = 1 Returned values : Schur form S, Schur form T, alpha, beta (eigenvalues = alpha/beta), HASH{info}: info output from gges/cgges. HASH{SL}: left Schur vectors if requested HASH{SR}: right Schur vectors if requested HASH{VL}: left eigenvectors if requested HASH{VR}: right eigenvectors if requested HASH{n} : Number of eigenvalues selected if select_func is defined. =for example my $a = random(10,10); my $b = random(10,10); my ($S,$T) = mgschur($a,$b); sub select{ my ($alpha,$beta) = @_; return $alpha->Cabs < abs($beta) ? 1 : 0; } my ($S, $T, $alpha, $beta, %res) = mgschur( $a, $b, 1, 1, 1, 1,\&select); =cut sub mgschur{ my $m = shift; $m->mgschur(@_); } sub PDL::mgschur{ my($m, $p, $jobvsl, $jobvsr, $jobvl, $jobvr, $select_func, $mult, $norm) = @_; my @mdims = $m->dims; my @pdims = $p->dims; barf("mgschur: Require square matrices of same order") unless( $mdims[0] == $mdims[1] && $pdims[0] == $pdims[1] && $mdims[0] == $pdims[0]); barf("mgschur: thread doesn't supported for selected vectors") if ($select_func && ((@mdims > 2) || (@pdims > 2)) && ($jobvsl == 2 || $jobvsr == 2 || $jobvl == 2 || $jobvr == 2)); my ($w, $vsl, $vsr, $info, $type, $select,$sdim, $vr,$vl, $mm, $pp, %ret, $beta); $mult = 1 unless defined($mult); $norm = 1 unless defined($norm); $type = $m->type; $select = $select_func ? pdl(long,1) : pdl(long,0); $info = null; $sdim = null; $mm = $m->is_inplace ? $m->xchg(0,1) : $m->xchg(0,1)->copy; $pp = $p->is_inplace ? $p->xchg(0,1) : $p->xchg(0,1)->copy; my ($select_f, $wi, $wtmp, $betai); if ($select_func){ $select_f= sub{ &$select_func(PDL::Complex::complex(pdl($type,@_[0..1])),pdl($_[2])); }; } $wtmp = null; $wi = null; $beta = null; # $vsl = $jobvsl ? PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]) : # pdl($type,[[0]]); # Lapack always write in VSL (g77 3.3) ??? $vsl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]); $vsr = $jobvsr ? PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]) : pdl($type,[[0]]); $mm->gges( $jobvsl, $jobvsr, $select, $pp, $wtmp, $wi, $beta, $vsl, $vsr, $sdim, $info, $select_f); if ($info->max > 0 && $_laerror){ my ($index, @list); $index = which((($info > 0)+($info <=$mdims[0])) == 2); unless ($index->isempty){ @list = $index->list; laerror("mgschur: The QZ algorithm failed to converge for matrix (PDL(s) @list): \$info = $info"); print ("Returning converged eigenvalues\n"); } $index = which((($info > 0)+($info <=($mdims[0]+1))) == 2); unless ($index->isempty){ @list = $index->list; laerror("mgschur: Error in hgeqz for matrix (PDL(s) @list): \$info = $info"); } if ($select_func){ $index = which((($info > 0)+($info == ($mdims[0]+3))) == 2); unless ($index->isempty){ laerror("mgschur: The eigenvalues could not be reordered because some\n". "eigenvalues were too close to separate (the problem". "is very ill-conditioned) for PDL(s) @list: \$info = $info"); } } } if ($select_func){ if ($jobvsl == 2 || $jobvsr == 2 || $jobvl == 2 || $jobvr == 2){ if ($info == ($mdims[0] + 2)){ warn("mgschur: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n") if $_laerror; #TODO : Check sdim and lapack $sdim+=1 if ($sdim < $mdims[0] && $wi($sdim) != 0 && $wi($sdim-1) == -$wi($sdim)); } } elsif($_laerror){ my $index = which((($info > 0)+($info == ($mdims[0]+2))) == 2); unless ($index->isempty){ my @list = $index->list; warn("mgschur: The Schur form no longer satisfy select_func = 1\n because". "of roundoff or underflow for PDL(s) @list: \$info = $info\n"); } } if ($jobvl == 2){ if (!$sdim){ $ret{VL} = PDL::Complex->null; $jobvl = 0; } } if ($jobvr == 2){ if(!$sdim){ $ret{VR} = PDL::Complex->null; $jobvr = 0; } } $ret{n} = $sdim; } if ($jobvl || $jobvr){ my ($sel, $job, $wtmpi, $wtmpr, $sdims); unless ($jobvr && $jobvl){ $job = $jobvl ? 2 : 1; } if ($select_func){ if ($jobvl == 1 || $jobvr == 1 || $mult){ $sdims = null; if ($jobvl){ if ($jobvsl){ $vl = $vsl->copy; } else{ $vl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]); $mult = 0; } } if ($jobvr){ if ($jobvsr){ $vr = $vsr->copy; } else{ $vr = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]); $mult = 0; } } $mm->tgevc($job, $mult, $pp, $sel, $vl, $vr, $sdims, my $infos=null); if ($jobvr){ if($norm){ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); bless $vr, 'PDL::Complex'; $ret{VR} = $jobvr == 2 ? magn_norm($vr(,,:($sdim-1)),1) : magn_norm($vr,1); } else{ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; $ret{VR} = $jobvr == 2 ? $vr(,:($sdim-1))->sever : $vr; } } if ($jobvl){ if ($norm){ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); bless $vl, 'PDL::Complex'; $ret{VL} = $jobvl == 2 ? magn_norm($vl(,,:($sdim-1)),1) : magn_norm($vl,1); } else{ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; $ret{VL} = $jobvl == 2 ? $vl(,:($sdim-1))->sever : $vl; } } } else{ $vr = PDL::new_from_specification('PDL', $type, $mdims[1], $sdim) if $jobvr; $vl = PDL::new_from_specification('PDL', $type, $mdims[1], $sdim) if $jobvl; $sel = zeroes($mdims[1]); $sel(:($sdim-1)) .= 1; $mm->tgevc($job, 2, $pp, $sel, $vl, $vr, $sdim, my $infos = null); $wtmpr = $wtmp(:($sdim-1)); $wtmpi = $wi(:($sdim-1)); if ($jobvr){ if ($norm){ (undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr,1); bless $vr, 'PDL::Complex'; $ret{VR} = magn_norm($vr,1); } else{ (undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; $ret{VR} = $vr; } } if ($jobvl){ if ($norm){ (undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl,1); bless $vl, 'PDL::Complex'; $ret{VL} = magn_norm($vl,1); } else{ (undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; $ret{VL} = $vl; } } } } else{ if ($jobvl){ if ($jobvsl){ $vl = $vsl->copy; } else{ $vl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]); $mult = 0; } } if ($jobvr){ if ($jobvsr){ $vr = $vsr->copy; } else{ $vr = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]); $mult = 0; } } $mm->tgevc($job, $mult, $pp, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvl){ if ($norm){ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); bless $vl, 'PDL::Complex'; $ret{VL} = magn_norm($vl,1); } else{ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; $ret{VL} = $vl; } } if ($jobvr){ if ($norm){ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); bless $vr, 'PDL::Complex'; $ret{VR} = magn_norm($vr,1); } else{ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; $ret{VR} = $vr; } } } } $w = PDL::Complex::ecplx ($wtmp, $wi); if ($jobvsr == 2 && $select_func) { $vsr = $sdim ? $vsr->xchg(0,1)->(:($sdim-1),) ->sever : null; $ret{SR} = $vsr; } elsif($jobvsr){ $vsr = $vsr->xchg(0,1)->sever; $ret{SR} = $vsr; } if ($jobvsl == 2 && $select_func) { $vsl = $sdim ? $vsl->xchg(0,1)->(:($sdim-1),) ->sever : null; $ret{SL} = $vsl; } elsif($jobvsl){ $vsl = $vsl->xchg(0,1)->sever; $ret{SL} = $vsl; } $ret{info} = $info; $m = $mm->xchg(0,1)->sever unless $m->is_inplace(0); $p = $pp->xchg(0,1)->sever unless $p->is_inplace(0); return ($m, $p, $w, $beta, %ret); } sub PDL::Complex::mgschur{ my($m, $p, $jobvsl, $jobvsr, $jobvl, $jobvr, $select_func, $mult, $norm) = @_; my @mdims = $m->dims; my @pdims = $p->dims; barf("mgschur: Require square matrices of same order") unless( $mdims[2] == $mdims[1] && $pdims[2] == $pdims[1] && $mdims[1] == $pdims[1]); barf("mgschur: thread doesn't supported for selected vectors") if ($select_func && ((@mdims > 2) || (@pdims > 2)) && ($jobvsl == 2 || $jobvsr == 2 || $jobvl == 2 || $jobvr == 2)); my ($w, $vsl, $vsr, $info, $type, $select,$sdim, $vr,$vl, $mm, $pp, %ret, $beta); $mult = 1 unless defined($mult); $norm = 1 unless defined($norm); $type = $m->type; $select = $select_func ? pdl(long,1) : pdl(long,0); $info = null; $sdim = null; $mm = $m->is_inplace ? $m->xchg(1,2) : $m->xchg(1,2)->copy; $pp = $p->is_inplace ? $p->xchg(1,2) : $p->xchg(1,2)->copy; $w = PDL::Complex->null; $beta = PDL::Complex->null; $vsr = $jobvsr ? PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]) : pdl($type,[0,0]); # $vsl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); $vsl = $jobvsl ? PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]) : pdl($type,[0,0]); $mm->cgges( $jobvsl, $jobvsr, $select, $pp, $w, $beta, $vsl, $vsr, $sdim, $info, $select_func); if ($info->max > 0 && $_laerror){ my ($index, @list); $index = which((($info > 0)+($info <=$mdims[1])) == 2); unless ($index->isempty){ @list = $index->list; laerror("mgschur: The QZ algorithm failed to converge for matrix (PDL(s) @list): \$info = $info"); print ("Returning converged eigenvalues\n"); } $index = which((($info > 0)+($info <=($mdims[1]+1))) == 2); unless ($index->isempty){ @list = $index->list; laerror("mgschur: Error in hgeqz for matrix (PDL(s) @list): \$info = $info"); } if ($select_func){ $index = which((($info > 0)+($info == ($mdims[1]+3))) == 2); unless ($index->isempty){ laerror("mgschur: The eigenvalues could not be reordered because some\n". "eigenvalues were too close to separate (the problem". "is very ill-conditioned) for PDL(s) @list: \$info = $info"); } } } if ($select_func){ if ($_laerror){ if (($jobvsl == 2 || $jobvsr == 2 || $jobvl == 2 || $jobvr == 2) && $info == ($mdims[1] + 2)){ warn("mgschur: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n"); } else{ my $index = which((($info > 0)+($info == ($mdims[1]+2))) == 2); unless ($index->isempty){ my @list = $index->list; warn("mgschur: The Schur form no longer satisfy select_func = 1\n because". "of roundoff or underflow for PDL(s) @list: \$info = $info\n"); } } } if ($jobvl == 2){ if (!$sdim){ $ret{VL} = PDL::Complex->null; $jobvl = 0; } } if ($jobvr == 2){ if(!$sdim){ $ret{VR} = PDL::Complex->null; $jobvr = 0; } } $ret{n} = $sdim; } if ($jobvl || $jobvr){ my ($sel, $job, $sdims); unless ($jobvr && $jobvl){ $job = $jobvl ? 2 : 1; } if ($select_func){ if ($jobvl == 1 || $jobvr == 1 || $mult){ $sdims = null; if ($jobvl){ if ($jobvsl){ $vl = $vsl->copy; } else{ $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]); $mult = 0; } } if ($jobvr){ if ($jobvsr){ $vr = $vsr->copy; } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]); $mult = 0; } } $mm->ctgevc($job, $mult, $pp, $sel, $vl, $vr, $sdims, my $infos=null); if ($jobvr){ if ($norm){ $ret{VR} = $jobvr == 2 ? magn_norm($vr(,,:($sdim-1)),1) : magn_norm($vr,1); } else{ $ret{VR} = $jobvr == 2 ? $vr(,,:($sdim-1))->xchg(1,2)->sever : $vr->xchg(1,2)->sever; } } if ($jobvl){ if ($norm){ $ret{VL} = $jobvl == 2 ? magn_norm($vl(,,:($sdim-1)),1) : magn_norm($vl,1); } else{ $ret{VL} = $jobvl == 2 ? $vl(,,:($sdim-1))->xchg(1,2)->sever : $vl->xchg(1,2)->sever; } } } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2,$mdims[1], $sdim) if $jobvr;; $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $sdim) if $jobvl;; $sel = zeroes($mdims[1]); $sel(:($sdim-1)) .= 1; $mm->ctgevc($job, 2, $pp, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvl){ $ret{VL} = $norm ? magn_norm($vl,1) : $vl->xchg(1,2)->sever; } if ($jobvr){ $ret{VR} = $norm ? magn_norm($vr,1) : $vr->xchg(1,2)->sever; } } } else{ if ($jobvl){ if ($jobvsl){ $vl = $vsl->copy; } else{ $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]); $mult = 0; } } if ($jobvr){ if ($jobvsr){ $vr = $vsr->copy; } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]); $mult = 0; } } $mm->ctgevc($job, $mult, $pp, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvl){ $ret{VL} = $norm ? magn_norm($vl,1) : $vl->xchg(1,2)->sever; } if ($jobvr){ $ret{VR} = $norm ? magn_norm($vr,1) : $vr->xchg(1,2)->sever; } } } if ($jobvsl == 2 && $select_func) { $vsl = $sdim ? $vsl->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; $ret{SL} = $vsl; } elsif($jobvsl){ $vsl = $vsl->xchg(1,2)->sever; $ret{SL} = $vsl; } if ($jobvsr == 2 && $select_func) { $vsr = $sdim ? $vsr->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; $ret{SR} = $vsr; } elsif($jobvsr){ $vsr = $vsr->xchg(1,2)->sever; $ret{SR} = $vsr; } $ret{info} = $info; $m = $mm->xchg(1,2)->sever unless $m->is_inplace(0); $p = $pp->xchg(1,2)->sever unless $p->is_inplace(0); return ($m, $p, $w, $beta, %ret); } =head2 mgschurx =for ref Computes generalized Schur decomposition of the pair (A,B). A = Q x S x Z' B = Q x T x Z' Uses L or L from Lapack. Works on transposed array. =for usage ( PDL(schur S), PDL(schur T), PDL(alpha), PDL(beta), HASH{result}) = mgschurx(PDL(A), PDL(B), SCALAR(left schur vector),SCALAR(right schur vector),SCALAR(left eigenvector), SCALAR(right eigenvector), SCALAR(select_func), SCALAR(sense), SCALAR(backtransform), SCALAR(scale)) left schur vector : Left Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 right schur vector : Right Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 left eigenvector : Left eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 right eigenvector : Right eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 select_func : Select_func is used to select eigenvalues to sort. to the top left of the Schur form. An eigenvalue w = wr(j)+sqrt(-1)*wi(j) is selected if PerlInt select_func(PDL::Complex(alpha),PDL | PDL::Complex (beta)) is true; Note that a selected complex eigenvalue may no longer satisfy select_func = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned). All eigenvalues/vectors are selected if select_func is undefined. sense : Determines which reciprocal condition numbers will be computed. 0: None are computed 1: Computed for average of selected eigenvalues only 2: Computed for selected deflating subspaces only 3: Computed for both If select_func is undefined, sense is not used. backtransform : Whether or not backtransforms eigenvectors to those of (A,B). Only supported if right and/or left schur vector are computed, default = 1 scale : Whether or not computed eigenvectors are scaled so the largest component will have abs(real part) + abs(imag. part) = 1, default = 1 Returned values : Schur form S, Schur form T, alpha, beta (eigenvalues = alpha/beta), HASH{info}: info output from gges/cgges. HASH{SL}: left Schur vectors if requested HASH{SR}: right Schur vectors if requested HASH{VL}: left eigenvectors if requested HASH{VR}: right eigenvectors if requested HASH{rconde}: reciprocal condition numbers for average of selected eigenvalues if requested HASH{rcondv}: reciprocal condition numbers for selected deflating subspaces if requested HASH{n} : Number of eigenvalues selected if select_func is defined. =for example my $a = random(10,10); my $b = random(10,10); my ($S,$T) = mgschurx($a,$b); sub select{ my ($alpha,$beta) = @_; return $alpha->Cabs < abs($beta) ? 1 : 0; } my ($S, $T, $alpha, $beta, %res) = mgschurx( $a, $b, 1, 1, 1, 1,\&select,3); =cut *mgschurx = \&PDL::mgschurx; sub PDL::mgschurx{ my($m, $p, $jobvsl, $jobvsr, $jobvl, $jobvr, $select_func, $sense, $mult, $norm) = @_; my (@mdims) = $m->dims; my (@pdims) = $p->dims; barf("mgschurx: Require square matrices of same order") unless( ( (@mdims == 2) || (@mdims == 3) )&& $mdims[-1] == $mdims[-2] && @mdims == @pdims && $pdims[-1] == $pdims[-2] && $mdims[1] == $pdims[1]); my ($w, $vsl, $vsr, $info, $type, $select, $sdim, $rconde, $rcondv, %ret, $mm, $vl, $vr, $beta, $pp); $mult = 1 unless defined($mult); $norm = 1 unless defined($norm); $type = $m->type; if ($select_func){ $select = pdl(long 1); $rconde = pdl($type,[0,0]); $rcondv = pdl($type,[0,0]); } else{ $select = pdl(long,0); $sense = pdl(long,0); $rconde = pdl($type,0); $rcondv = pdl($type,0); } $info = pdl(long,0); $sdim = pdl(long,0); $mm = $m->is_inplace ? $m->xchg(-1,-2) : $m->xchg(-1,-2)->copy; $pp = $p->is_inplace ? $p->xchg(-1,-2) : $p->xchg(-1,-2)->copy; if (@mdims == 3){ $w = PDL::Complex->null; $beta = PDL::Complex->null; # $vsl = $jobvsl ? PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]) : # pdl($type,[0,0]); $vsl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); $vsr = $jobvsr ? PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]) : pdl($type,[0,0]); $mm->cggesx( $jobvsl, $jobvsr, $select, $sense, $pp, $w, $beta, $vsl, $vsr, $sdim, $rconde, $rcondv,$info, $select_func); if ($info){ if ($info < $mdims[1]){ laerror("mgschurx: The QZ algorithm failed to converge"); print ("Returning converged eigenvalues\n") if $_laerror; } laerror("mgschurx: The eigenvalues could not be reordered because some\n". "eigenvalues were too close to separate (the problem". "is very ill-conditioned)") if $info == ($mdims[1] + 3); laerror("mgschurx: Error in hgeqz\n") if $info == ($mdims[1] + 1); warn("mgschurx: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n") if ($info == ($mdims[1] + 2) and $_laerror); } if ($select_func){ if(!$sdim){ if ($jobvl == 2){ $ret{VL} = PDL::Complex->null; $jobvl = 0; } if ($jobvr == 2){ $ret{VR} = PDL::Complex->null; $jobvr = 0; } } $ret{n} = $sdim; } if ($jobvl || $jobvr){ my ($sel, $job, $sdims); unless ($jobvr && $jobvl){ $job = $jobvl ? 2 : 1; } if ($select_func){ if ($jobvl == 1 || $jobvr == 1 || $mult){ $sdims = null; if ($jobvl){ if ($jobvsl){ $vl = $vsl->copy; } else{ $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); $mult = 0; } } if ($jobvr){ if ($jobvsr){ $vr = $vsr->copy; } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); $mult = 0; } } $mm->ctgevc($job, $mult, $pp, $sel, $vl, $vr, $sdims, my $infos=null); if ($jobvr){ if ($norm){ $ret{VR} = $jobvr == 2 ? magn_norm($vr(,,:($sdim-1)),1) : magn_norm($vr,1); } else{ $ret{VR} = $jobvr == 2 ? $vr(,,:($sdim-1))->xchg(1,2)->sever : $vr->xchg(1,2)->sever; } } if ($jobvl){ if ($norm){ $ret{VL} = $jobvl == 2 ? magn_norm($vl(,,:($sdim-1)),1) : magn_norm($vl,1); } else{ $ret{VL} = $jobvl == 2 ? $vl(,,:($sdim-1))->xchg(1,2)->sever : $vl->xchg(1,2)->sever; } } } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2,$mdims[1], $sdim) if $jobvr; $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $sdim) if $jobvl; $sel = zeroes($mdims[1]); $sel(:($sdim-1)) .= 1; $mm->ctgevc($job, 2, $pp, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvl){ $ret{VL} = $norm ? magn_norm($vl,1) : $vl->xchg(1,2)->sever; } if ($jobvr){ $ret{VR} = $norm ? magn_norm($vr,1) : $vr->xchg(1,2)->sever; } } } else{ if ($jobvl){ if ($jobvsl){ $vl = $vsl->copy; } else{ $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); $mult = 0; } } if ($jobvr){ if ($jobvsr){ $vr = $vsr->copy; } else{ $vr = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); $mult = 0; } } $mm->ctgevc($job, $mult, $pp,$sel, $vl, $vr, $sdim, my $infos=null); if ($jobvl){ $ret{VL} = $norm ? magn_norm($vl,1) : $vl->xchg(1,2)->sever; } if ($jobvr){ $ret{VR} = $norm ? magn_norm($vr,1) : $vr->xchg(1,2)->sever; } } } if ($jobvsl == 2 && $select_func) { $vsl = $sdim > 0 ? $vsl->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; $ret{SL} = $vsl; } elsif($jobvsl){ $vsl = $vsl->xchg(1,2)->sever; $ret{SL} = $vsl; } if ($jobvsr == 2 && $select_func) { $vsr = $sdim > 0 ? $vsr->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; $ret{SR} = $vsr; } elsif($jobvsr){ $vsr = $vsr->xchg(1,2)->sever; $ret{SR} = $vsr; } } else{ my ($select_f, $wi, $wtmp); if ($select_func){ no strict 'refs'; $select_f= sub{ &$select_func(PDL::Complex::complex(pdl($type,$_[0],$_[1])), $_[2]); }; } $wi = null; $wtmp = null; $beta = null; #$vsl = $jobvsl ? PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]) : # pdl($type,[[0]]); $vsl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]); $vsr = $jobvsr ? PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]) : pdl($type,[[0]]); $mm->ggesx( $jobvsl, $jobvsr, $select, $sense, $pp, $wtmp, $wi, $beta, $vsl, $vsr, $sdim, $rconde, $rcondv,$info, $select_f); if ($info){ if ($info < $mdims[0]){ laerror("mgschurx: The QZ algorithm failed to converge"); print ("Returning converged eigenvalues\n") if $_laerror; } laerror("mgschurx: The eigenvalues could not be reordered because some\n". "eigenvalues were too close to separate (the problem". "is very ill-conditioned)") if $info == ($mdims[0] + 3); laerror("mgschurx: Error in hgeqz\n") if $info == ($mdims[0] + 1); if ($info == ($mdims[0] + 2)){ warn("mgschur: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n") if $_laerror; $sdim+=1 if ($sdim < $mdims[0] && $wi($sdim) != 0 && $wi($sdim-1) == -$wi($sdim)); } } if ($select_func){ if(!$sdim){ if ($jobvl == 2){ $ret{VL} = null; $jobvl = 0; } if ($jobvr == 2){ $ret{VR} = null; $jobvr = 0; } } $ret{n} = $sdim; } if ($jobvl || $jobvr){ my ($sel, $job, $wtmpi, $wtmpr, $sdims); unless ($jobvr && $jobvl){ $job = $jobvl ? 2 : 1; } if ($select_func){ $sdims = null; if ($jobvl == 1 || $jobvr == 1 || $mult){ if ($jobvl){ if ($jobvsl){ $vl = $vsl->copy; } else{ $vl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]); $mult = 0; } } if ($jobvr){ if ($jobvsr){ $vr = $vsr->copy; } else{ $vr = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]); $mult = 0; } } $mm->tgevc($job, $mult, $pp, $sel, $vl, $vr, $sdims, my $infos=null); if ($jobvr){ if($norm){ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); bless $vr, 'PDL::Complex'; $ret{VR} = $jobvr == 2 ? magn_norm($vr(,,:($sdim-1)),1) : magn_norm($vr,1); } else{ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; $ret{VR} = $jobvr == 2 ? $vr(,:($sdim-1))->sever : $vr; } } if ($jobvl){ if ($norm){ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); bless $vl, 'PDL::Complex'; $ret{VL} = $jobvl == 2 ? magn_norm($vl(,,:($sdim-1)),1) : magn_norm($vl,1); } else{ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; $ret{VL} = $jobvl == 2 ? $vl(,:($sdim-1))->sever : $vl; } } } else{ $vr = PDL::new_from_specification('PDL', $type, $mdims[1], $sdim) if $jobvr; $vl = PDL::new_from_specification('PDL', $type, $mdims[1], $sdim) if $jobvl; $sel = zeroes($mdims[1]); $sel(:($sdim-1)) .= 1; $mm->tgevc($job, 2, $pp, $sel, $vl, $vr, $sdim, my $infos = null); $wtmpr = $wtmp(:($sdim-1)); $wtmpi = $wi(:($sdim-1)); if ($jobvr){ if ($norm){ (undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr,1); bless $vr, 'PDL::Complex'; $ret{VR} = magn_norm($vr,1); } else{ (undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; $ret{VR} = $vr; } } if ($jobvl){ if ($norm){ (undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl,1); bless $vl, 'PDL::Complex'; $ret{VL} = magn_norm($vl,1); } else{ (undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; $ret{VL} = $vl; } } } } else{ if ($jobvl){ if ($jobvsl){ $vl = $vsl->copy; } else{ $vl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]); $mult = 0; } } if ($jobvr){ if ($jobvsr){ $vr = $vsr->copy; } else{ $vr = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]); $mult = 0; } } $mm->tgevc($job, $mult, $pp, $sel, $vl, $vr, $sdim, my $infos=null); if ($jobvl){ if ($norm){ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); bless $vl, 'PDL::Complex'; $ret{VL} = magn_norm($vl,1); } else{ (undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); bless $vl, 'PDL::Complex'; $ret{VL} = $vl; } } if ($jobvr){ if ($norm){ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); bless $vr, 'PDL::Complex'; $ret{VR} = magn_norm($vr,1); } else{ (undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); bless $vr, 'PDL::Complex'; $ret{VR} = $vr; } } } } $w = PDL::Complex::ecplx ($wtmp, $wi); if ($jobvsr == 2 && $select_func) { $vsr = $sdim > 0 ? $vsr->xchg(0,1)->(:($sdim-1),) ->sever : null; $ret{SR} = $vsr; } elsif($jobvsr){ $vsr = $vsr->xchg(0,1)->sever; $ret{SR} = $vsr; } if ($jobvsl == 2 && $select_func) { $vsl = $sdim > 0 ? $vsl->xchg(0,1)->(:($sdim-1),) ->sever : null; $ret{SL} = $vsl; } elsif($jobvsl){ $vsl = $vsl->xchg(0,1)->sever; $ret{SL} = $vsl; } } $ret{info} = $info; if ($sense){ if ($sense == 3){ $ret{rconde} = $rconde; $ret{rcondv} = $rcondv; } else{ $ret{rconde} = $rconde if ($sense == 1); $ret{rcondv} = $rcondv if ($sense == 2); } } $m = $mm->xchg(-1,-2)->sever unless $m->is_inplace(0); $p = $pp->xchg(-1,-2)->sever unless $p->is_inplace(0); return ($m, $p, $w, $beta, %ret); } =head2 mqr =for ref Computes QR decomposition. For complex number needs object of type PDL::Complex. Uses L and L or L and L from Lapack and returns C in scalar context. Works on transposed array. =for usage (PDL(Q), PDL(R), PDL(info)) = mqr(PDL, SCALAR) SCALAR : ECONOMIC = 0 | FULL = 1, default = 0 =for example my $a = random(10,10); my ( $q, $r ) = mqr($a); # Can compute full decomposition if nrow > ncol $a = random(5,7); ( $q, $r ) = $a->mqr(1); =cut sub mqr{ my $m = shift; $m->mqr(@_); } sub PDL::mqr { my($m, $full) = @_; my(@dims) = $m->dims; my ($q, $r); barf("mqr: Require a matrix") unless @dims == 2; $m = $m->xchg(0,1)->copy; my $min = $dims[0] < $dims[1] ? $dims[0] : $dims[1]; my $tau = zeroes($m->type, $min); $m->geqrf($tau, (my $info = pdl(long,0))); if ($info){ laerror("mqr: Error $info in geqrf\n"); $q = $r = $m; } else{ $q = $dims[0] > $dims[1] ? $m(:,:($min-1))->copy : $m->copy; $q->reshape($dims[1], $dims[1]) if $full && $dims[0] < $dims[1]; $q->orgqr($tau, $info); return $q->xchg(0,1)->sever unless wantarray; if ($dims[0] < $dims[1] && !$full){ $r = zeroes($m->type, $min, $min); $m->xchg(0,1)->(,:($min-1))->tricpy(0,$r); } else{ $r = zeroes($m->type, $dims[0],$dims[1]); $m->xchg(0,1)->tricpy(0,$r); } } return ($q->xchg(0,1)->sever, $r, $info); } sub PDL::Complex::mqr { my($m, $full) = @_; my(@dims) = $m->dims; my ($q, $r); barf("mqr: Require a matrix") unless @dims == 3; $m = $m->xchg(1,2)->copy; my $min = $dims[1] < $dims[2] ? $dims[1] : $dims[2]; my $tau = zeroes($m->type, 2, $min); $m->cgeqrf($tau, (my $info = pdl(long,0))); if ($info){ laerror("mqr: Error $info in cgeqrf\n"); $q = $r = $m; } else{ $q = $dims[1] > $dims[2] ? $m(,:,:($min-1))->copy : $m->copy; $q->reshape(2,$dims[2], $dims[2]) if $full && $dims[1] < $dims[2]; $q->cungqr($tau, $info); return $q->xchg(1,2)->sever unless wantarray; if ($dims[1] < $dims[2] && !$full){ $r = PDL::new_from_specification('PDL::Complex',$m->type, 2, $min, $min); $r .= 0; $m->xchg(1,2)->(,,:($min-1))->ctricpy(0,$r); } else{ $r = PDL::new_from_specification('PDL::Complex', $m->type, 2, $dims[1],$dims[2]); $r .= 0; $m->xchg(1,2)->ctricpy(0,$r); } } return ($q->xchg(1,2)->sever, $r, $info); } =head2 mrq =for ref Computes RQ decomposition. For complex number needs object of type PDL::Complex. Uses L and L or L and L from Lapack and returns C in scalar context. Works on transposed array. =for usage (PDL(R), PDL(Q), PDL(info)) = mrq(PDL, SCALAR) SCALAR : ECONOMIC = 0 | FULL = 1, default = 0 =for example my $a = random(10,10); my ( $r, $q ) = mrq($a); # Can compute full decomposition if nrow < ncol $a = random(5,7); ( $r, $q ) = $a->mrq(1); =cut sub mrq{ my $m = shift; $m->mrq(@_); } sub PDL::mrq { my($m, $full) = @_; my(@dims) = $m->dims; my ($q, $r); barf("mrq: Require a matrix") unless @dims == 2; $m = $m->xchg(0,1)->copy; my $min = $dims[0] < $dims[1] ? $dims[0] : $dims[1]; my $tau = zeroes($m->type, $min); $m->gerqf($tau, (my $info = pdl(long,0))); if ($info){ laerror ("mrq: Error $info in gerqf\n"); $r = $q = $m; } else{ if ($dims[0] > $dims[1] && $full){ $q = zeroes($m->type, $dims[0],$dims[0]); $q(($dims[0] - $dims[1]):,:) .= $m; } elsif ($dims[0] < $dims[1]){ $q = $m(($dims[1] - $dims[0]):,:)->copy; } else{ $q = $m->copy; } $q->orgrq($tau, $info); return $q->xchg(0,1)->sever unless wantarray; if ($dims[0] > $dims[1] && $full){ $r = zeroes ($m->type,$dims[0],$dims[1]); $m->xchg(0,1)->tricpy(0,$r); $r(:($min-1),:($min-1))->diagonal(0,1) .= 0; } elsif ($dims[0] < $dims[1]){ my $temp = zeroes($m->type,$dims[1],$dims[1]); $temp(-$min:, :) .= $m->xchg(0,1)->sever; $r = PDL::zeroes($temp); $temp->tricpy(0,$r); $r = $r(-$min:, :); } else{ $r = zeroes($m->type, $min, $min); $m->xchg(0,1)->(($dims[0] - $dims[1]):, :)->tricpy(0,$r); } } return ($r, $q->xchg(0,1)->sever, $info); } sub PDL::Complex::mrq { my($m, $full) = @_; my(@dims) = $m->dims; my ($q, $r); barf("mrq: Require a matrix") unless @dims == 3; $m = $m->xchg(1,2)->copy; my $min = $dims[1] < $dims[2] ? $dims[1] : $dims[2]; my $tau = zeroes($m->type, 2, $min); $m->cgerqf($tau, (my $info = pdl(long,0))); if ($info){ laerror ("mrq: Error $info in cgerqf\n"); $r = $q = $m; } else{ if ($dims[1] > $dims[2] && $full){ $q = PDL::new_from_specification('PDL::Complex',$m->type, 2, $dims[1],$dims[1]); $q .= 0; $q(,($dims[1] - $dims[2]):,:) .= $m; } elsif ($dims[1] < $dims[2]){ $q = $m(,($dims[2] - $dims[1]):,:)->copy; } else{ $q = $m->copy; } $q->cungrq($tau, $info); return $q->xchg(1,2)->sever unless wantarray; if ($dims[1] > $dims[2] && $full){ $r = PDL::new_from_specification('PDL::Complex',$m->type,2,$dims[1],$dims[2]); $r .= 0; $m->xchg(1,2)->ctricpy(0,$r); $r(,:($min-1),:($min-1))->diagonal(1,2) .= 0; } elsif ($dims[1] < $dims[2]){ my $temp = PDL::new_from_specification('PDL::Complex',$m->type,2,$dims[2],$dims[2]); $temp .= 0; $temp(,-$min:, :) .= $m->xchg(1,2); $r = PDL::zeroes($temp); $temp->ctricpy(0,$r); $r = $r(,-$min:, :)->sever; } else{ $r = PDL::new_from_specification('PDL::Complex',$m->type, 2,$min, $min); $r .= 0; $m->xchg(1,2)->(,($dims[1] - $dims[2]):, :)->ctricpy(0,$r); } } return ($r, $q->xchg(1,2)->sever, $info); } =head2 mql =for ref Computes QL decomposition. For complex number needs object of type PDL::Complex. Uses L and L or L and L from Lapack and returns C in scalar context. Works on transposed array. =for usage (PDL(Q), PDL(L), PDL(info)) = mql(PDL, SCALAR) SCALAR : ECONOMIC = 0 | FULL = 1, default = 0 =for example my $a = random(10,10); my ( $q, $l ) = mql($a); # Can compute full decomposition if nrow > ncol $a = random(5,7); ( $q, $l ) = $a->mql(1); =cut sub mql{ my $m = shift; $m->mql(@_); } sub PDL::mql { my($m, $full) = @_; my(@dims) = $m->dims; my ($q, $l); barf("mql: Require a matrix") unless @dims == 2; $m = $m->xchg(0,1)->copy; my $min = $dims[0] < $dims[1] ? $dims[0] : $dims[1]; my $tau = zeroes($m->type, $min); $m->geqlf($tau, (my $info = pdl(long,0))); if ($info){ laerror("mql: Error $info in geqlf\n"); $q = $l = $m; } else{ if ($dims[0] < $dims[1] && $full){ $q = zeroes($m->type, $dims[1],$dims[1]); $q(:, -$dims[0]:) .= $m; } elsif ($dims[0] > $dims[1]){ $q = $m(:,-$min:)->copy; } else{ $q = $m->copy; } $q->orgql($tau, $info); return $q->xchg(0,1)->sever unless wantarray; if ($dims[0] < $dims[1] && $full){ $l = zeroes ($m->type,$dims[0],$dims[1]); $m->xchg(0,1)->tricpy(1,$l); $l(:($min-1),:($min-1))->diagonal(0,1) .= 0; } elsif ($dims[0] > $dims[1]){ my $temp = zeroes($m->type,$dims[0],$dims[0]); $temp(:, -$dims[1]:) .= $m->xchg(0,1); $l = PDL::zeroes($temp); $temp->tricpy(1,$l); $l = $l(:, -$dims[1]:)->sever; } else{ $l = zeroes($m->type, $min, $min); $m->xchg(0,1)->(:,($dims[1]-$min):)->tricpy(1,$l); } } return ($q->xchg(0,1)->sever, $l, $info); } sub PDL::Complex::mql{ my($m, $full) = @_; my(@dims) = $m->dims; my ($q, $l); barf("mql: Require a matrix") unless @dims == 3; $m = $m->xchg(1,2)->copy; my $min = $dims[1] < $dims[2] ? $dims[1] : $dims[2]; my $tau = zeroes($m->type, 2, $min); $m->cgeqlf($tau, (my $info = pdl(long,0))); if ($info){ laerror("mql: Error $info in cgeqlf\n"); $q = $l = $m; } else{ if ($dims[1] < $dims[2] && $full){ $q = PDL::new_from_specification('PDL::Complex', $m->type, 2, $dims[2],$dims[2]); $q .= 0; $q(,:, -$dims[1]:) .= $m; } elsif ($dims[1] > $dims[2]){ $q = $m(,:,-$min:)->copy; } else{ $q = $m->copy; } $q->cungql($tau, $info); return $q->xchg(1,2)->sever unless wantarray; if ($dims[1] < $dims[2] && $full){ $l = PDL::new_from_specification('PDL::Complex', $m->type, 2, $dims[1], $dims[2]); $l .= 0; $m->xchg(1,2)->ctricpy(1,$l); $l(,:($min-1),:($min-1))->diagonal(1,2) .= 0; } elsif ($dims[1] > $dims[2]){ my $temp = PDL::new_from_specification('PDL::Complex',$m->type,2,$dims[1],$dims[1]); $temp .= 0; $temp(,, -$dims[2]:) .= $m->xchg(1,2); $l = PDL::zeroes($temp); $temp->ctricpy(1,$l); $l = $l(,, -$dims[2]:)->sever; } else{ $l = PDL::new_from_specification('PDL::Complex',$m->type, 2, $min, $min); $l .= 0; $m->xchg(1,2)->(,,($dims[2]-$min):)->ctricpy(1,$l); } } return ($q->xchg(1,2)->sever, $l, $info); } =head2 mlq =for ref Computes LQ decomposition. For complex number needs object of type PDL::Complex. Uses L and L or L and L from Lapack and returns C in scalar context. Works on transposed array. =for usage ( PDL(L), PDL(Q), PDL(info) ) = mlq(PDL, SCALAR) SCALAR : ECONOMIC = 0 | FULL = 1, default = 0 =for example my $a = random(10,10); my ( $l, $q ) = mlq($a); # Can compute full decomposition if nrow < ncol $a = random(5,7); ( $l, $q ) = $a->mlq(1); =cut sub mlq{ my $m = shift; $m->mlq(@_); } sub PDL::mlq { my($m, $full) = @_; my(@dims) = $m->dims; my ($q, $l); barf("mlq: Require a matrix") unless @dims == 2; $m = $m->xchg(0,1)->copy; my $min = $dims[0] < $dims[1] ? $dims[0] : $dims[1]; my $tau = zeroes($m->type, $min); $m->gelqf($tau, (my $info = pdl(long,0))); if ($info){ laerror("mlq: Error $info in gelqf\n"); $q = $l = $m; } else{ if ($dims[0] > $dims[1] && $full){ $q = zeroes($m->type, $dims[0],$dims[0]); $q(:($min -1),:) .= $m; } elsif ($dims[0] < $dims[1]){ $q = $m(:($min-1),)->copy; } else{ $q = $m->copy; } $q->orglq($tau, $info); return $q->xchg(0,1)->sever unless wantarray; if ($dims[0] > $dims[1] && !$full){ $l = zeroes($m->type, $dims[1], $dims[1]); $m->xchg(0,1)->(:($min-1))->tricpy(1,$l); } else{ $l = zeroes($m->type, $dims[0], $dims[1]); $m->xchg(0,1)->tricpy(1,$l); } } return ($l, $q->xchg(0,1)->sever, $info); } sub PDL::Complex::mlq{ my($m, $full) = @_; my(@dims) = $m->dims; my ($q, $l); barf("mlq: Require a matrix") unless @dims == 3; $m = $m->xchg(1,2)->copy; my $min = $dims[1] < $dims[2] ? $dims[1] : $dims[2]; my $tau = zeroes($m->type, 2, $min); $m->cgelqf($tau, (my $info = pdl(long,0))); if ($info){ laerror("mlq: Error $info in cgelqf\n"); $q = $l = $m; } else{ if ($dims[1] > $dims[2] && $full){ $q = PDL::new_from_specification('PDL::Complex',$m->type, 2, $dims[1],$dims[1]); $q .= 0; $q(,:($min -1),:) .= $m; } elsif ($dims[1] < $dims[2]){ $q = $m(,:($min-1),)->copy; } else{ $q = $m->copy; } $q->cunglq($tau, $info); return $q->xchg(1,2)->sever unless wantarray; if ($dims[1] > $dims[2] && !$full){ $l = PDL::new_from_specification('PDL::Complex',$m->type, 2, $dims[2], $dims[2]); $l .= 0; $m->xchg(1,2)->(,:($min-1))->ctricpy(1,$l); } else{ $l = PDL::new_from_specification('PDL::Complex',$m->type, 2, $dims[1], $dims[2]); $l .= 0; $m->xchg(1,2)->ctricpy(1,$l); } } return ($l, $q->xchg(1,2)->sever, $info); } =head2 msolve =for ref Solves linear system of equations using LU decomposition. A * X = B Returns X in scalar context else X, LU, pivot vector and info. B is overwritten by X if its inplace flag is set. Supports threading. Uses L or L from Lapack. Works on transposed arrays. =for usage (PDL(X), (PDL(LU), PDL(pivot), PDL(info))) = msolve(PDL(A), PDL(B) ) =for example my $a = random(5,5); my $b = random(10,5); my $X = msolve($a, $b); =cut sub msolve{ my $m = shift; $m->msolve(@_); } sub PDL::msolve { my($a, $b) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($ipiv, $info, $c); barf("msolve: Require square coefficient array(s)") unless( (@adims >= 2) && $adims[0] == $adims[1] ); barf("msolve: Require right hand side array(s) B with number". " of row equal to number of columns of A") unless( (@bdims >= 2) && $bdims[1] == $adims[0]); barf("msolve: Require arrays with equal number of dimensions") if( @adims != @bdims); $a = $a->xchg(0,1)->copy; $c = $b->is_inplace ? $b->xchg(0,1) : $b->xchg(0,1)->copy; $ipiv = zeroes(long, @adims[1..$#adims]); @adims = @adims[2..$#adims]; $info = @adims ? zeroes(long,@adims) : pdl(long,0); $a->gesv($c, $ipiv, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msolve: Can't solve system of linear equations (after getrf factorization): matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } return wantarray ? $b->is_inplace(0) ? ($b, $a->xchg(0,1)->sever, $ipiv, $info) : ($c->xchg(0,1)->sever , $a->xchg(0,1)->sever, $ipiv, $info) : $b->is_inplace(0) ? $b : $c->xchg(0,1)->sever; } sub PDL::Complex::msolve { my($a, $b) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($ipiv, $info, $c); barf("msolve: Require square coefficient array(s)") unless( (@adims >= 3) && $adims[1] == $adims[2] ); barf("msolve: Require right hand side array(s) B with number". " of row equal to order of A") unless( (@bdims >= 3) && $bdims[2] == $adims[1]); barf("msolve: Require arrays with equal number of dimensions") if( @adims != @bdims); $a = $a->xchg(1,2)->copy; $c = $b->is_inplace ? $b->xchg(1,2) : $b->xchg(1,2)->copy; $ipiv = zeroes(long, @adims[2..$#adims]); @adims = @adims[3..$#adims]; $info = @adims ? zeroes(long,@adims) : pdl(long,0); $a->cgesv($c, $ipiv, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msolve: Can't solve system of linear equations (after cgetrf factorization): matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } return wantarray ? $b->is_inplace(0) ? ($b, $a->xchg(1,2)->sever, $ipiv, $info) : ($c->xchg(1,2)->sever , $a->xchg(1,2)->sever, $ipiv, $info): $b->is_inplace(0) ? $b : $c->xchg(1,2)->sever; } =head2 msolvex =for ref Solves linear system of equations using LU decomposition. A * X = B Can optionnally equilibrate the matrix. Uses L or L from Lapack. Works on transposed arrays. =for usage (PDL, (HASH(result))) = msolvex(PDL(A), PDL(B), HASH(options)) where options are: transpose: solves A' * X = B 0: false 1: true equilibrate: equilibrates A if necessary. form equilibration is returned in HASH{'equilibration'}: 0: no equilibration 1: row equilibration 2: column equilibration row scale factors are returned in HASH{'row'} column scale factors are returned in HASH{'column'} 0: false 1: true LU: returns lu decomposition in HASH{LU} 0: false 1: true A: returns scaled A if equilibration was done in HASH{A} 0: false 1: true B: returns scaled B if equilibration was done in HASH{B} 0: false 1: true Returned values: X (SCALAR CONTEXT), HASH{'pivot'}: Pivot indice from LU factorization HASH{'rcondition'}: Reciprocal condition of the matrix HASH{'ferror'}: Forward error bound HASH{'berror'}: Componentwise relative backward error HASH{'rpvgrw'}: Reciprocal pivot growth factor HASH{'info'}: Info: output from gesvx =for example my $a = random(10,10); my $b = random(5,10); my %options = ( LU=>1, equilibrate => 1, ); my( $X, %result) = msolvex($a,$b,%options); =cut *msolvex = \&PDL::msolvex; sub PDL::msolvex { my($a, $b, %opt) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ( $af, $x, $ipiv, $info, $equilibrate, $berr, $ferr, $rcond, $equed, %result, $r, $c ,$rpvgrw); barf("msolvex: Require a square coefficient matrix") unless( ((@adims == 2) || (@adims == 3)) && $adims[-1] == $adims[-2] ); barf("msolvex: Require a right hand side matrix B with number". " of row equal to order of A") unless( ((@bdims == 2) || (@bdims == 3))&& $bdims[-1] == $adims[-2]); $equilibrate = $opt{'equilibrate'} ? pdl(long, 2): pdl(long,1); $a = $a->t->copy; $b = $b->t->copy; $x = PDL::zeroes $b; $af = PDL::zeroes $a; $info = pdl(long, 0); $rcond = null; $rpvgrw = null; $equed = pdl(long, 0); $c = zeroes($a->type, $adims[-2]); $r = zeroes($a->type, $adims[-2]); $ipiv = zeroes(long, $adims[-2]); $ferr = zeroes($b->type, $bdims[-2]); $berr = zeroes($b->type, $bdims[-2]); ( @adims == 3 ) ? $a->cgesvx($opt{'transpose'}, $equilibrate, $b, $af, $ipiv, $equed, $r, $c, $x, $rcond, $ferr, $berr, $rpvgrw,$info) : $a->gesvx($opt{'transpose'}, $equilibrate, $b, $af, $ipiv, $equed, $r, $c, $x, $rcond, $ferr, $berr, $rpvgrw,$info); if( $info < $adims[-2] && $info > 0){ $info--; laerror("msolvex: Can't solve system of linear equations:\nfactor U($info,$info)". " of coefficient matrix is exactly 0"); } elsif ($info != 0 and $_laerror){ warn ("msolvex: The matrix is singular to working precision"); } return $x->xchg(-1,-2)->sever unless wantarray; $result{rcondition} = $rcond; $result{ferror} = $ferr; $result{berror} = $berr; if ($opt{equilibrate}){ $result{equilibration} = $equed; $result{row} = $r if $equed == 1 || $equed == 3; $result{column} = $c if $equed == 2 || $equed == 3; if ($equed){ $result{A} = $a->xchg(-2,-1)->sever if $opt{A}; $result{B} = $b->xchg(-2,-1)->sever if $opt{B}; } } $result{pivot} = $ipiv; $result{rpvgrw} = $rpvgrw; $result{info} = $info; $result{LU} = $af->xchg(-2,-1)->sever if $opt{LU}; return ($x->xchg(-2,-1)->sever, %result); } =head2 mtrisolve =for ref Solves linear system of equations with triangular matrix A. A * X = B or A' * X = B B is overwritten by X if its inplace flag is set. Supports threading. Uses L or L from Lapack. Work on transposed array(s). =for usage (PDL(X), (PDL(info)) = mtrisolve(PDL(A), SCALAR(uplo), PDL(B), SCALAR(trans), SCALAR(diag)) uplo : UPPER = 0 | LOWER = 1 trans : NOTRANSPOSE = 0 | TRANSPOSE = 1, default = 0 uplo : UNITARY DIAGONAL = 1, default = 0 =for example # Assume $a is upper triagonal my $a = random(5,5); my $b = random(5,10); my $X = mtrisolve($a, 0, $b); =cut sub mtrisolve{ my $m = shift; $m->mtrisolve(@_); } sub PDL::mtrisolve{ my($a, $uplo, $b, $trans, $diag) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($info, $c); barf("mtrisolve: Require square coefficient array(s)") unless( (@adims >= 2) && $adims[0] == $adims[1] ); barf("mtrisolve: Require 2D right hand side array(s) B with number". " of row equal to order of A") unless( (@bdims >= 2) && $bdims[1] == $adims[0]); barf("mtrisolve: Require arrays with equal number of dimensions") if( @adims != @bdims); $uplo = 1 - $uplo; $trans = 1 - $trans; $c = $b->is_inplace ? $b->xchg(0,1) : $b->xchg(0,1)->copy; @adims = @adims[2..$#adims]; $info = @adims ? zeroes(long,@adims) : pdl(long,0); $a->trtrs($uplo, $trans, $diag, $c, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mtrisolve: Can't solve system of linear equations: matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } return wantarray ? $b->is_inplace(0) ? ($b, $info) : ($c->xchg(0,1)->sever, $info) : $b->is_inplace(0) ? $b : $c->xchg(0,1)->sever; } sub PDL::Complex::mtrisolve{ my($a, $uplo, $b, $trans, $diag) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($info, $c); barf("mtrisolve: Require square coefficient array(s)") unless( (@adims >= 3) && $adims[1] == $adims[2] ); barf("mtrisolve: Require 2D right hand side array(s) B with number". " of row equal to order of A") unless( (@bdims >= 3) && $bdims[2] == $adims[1]); barf("mtrisolve: Require arrays with equal number of dimensions") if( @adims != @bdims); $uplo = 1 - $uplo; $trans = 1 - $trans; $c = $b->is_inplace ? $b->xchg(1,2) : $b->xchg(1,2)->copy; @adims = @adims[3..$#adims]; $info = @adims ? zeroes(long,@adims) : pdl(long,0); $a->ctrtrs($uplo, $trans, $diag, $c, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mtrisolve: Can't solve system of linear equations: matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } return wantarray ? $b->is_inplace(0) ? ($b, $info) : ($c->xchg(1,2)->sever, $info) : $b->is_inplace(0) ? $b : $c->xchg(1,2)->sever; } =head2 msymsolve =for ref Solves linear system of equations using diagonal pivoting method with symmetric matrix A. A * X = B Returns X in scalar context else X, block diagonal matrix D (and the multipliers), pivot vector an info. B is overwritten by X if its inplace flag is set. Supports threading. Uses L or L from Lapack. Works on transposed array(s). =for usage (PDL(X), ( PDL(D), PDL(pivot), PDL(info) ) ) = msymsolve(PDL(A), SCALAR(uplo), PDL(B) ) uplo : UPPER = 0 | LOWER = 1, default = 0 =for example # Assume $a is symmetric my $a = random(5,5); my $b = random(5,10); my $X = msymsolve($a, 0, $b); =cut sub msymsolve{ my $m = shift; $m->msymsolve(@_); } sub PDL::msymsolve { my($a, $uplo, $b) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($ipiv, $info, $c); barf("msymsolve: Require square coefficient array(s)") unless( (@adims >= 2) && $adims[0] == $adims[1] ); barf("msymsolve: Require 2D right hand side array(s) B with number". " of row equal to order of A") unless( (@bdims >= 2)&& $bdims[1] == $adims[0]); barf("msymsolve: Require array(s) with equal number of dimensions") if( @adims != @bdims); $uplo = 1 - $uplo; $a = $a->copy; $c = $b->is_inplace ? $b->xchg(0,1) : $b->xchg(0,1)->copy; $ipiv = zeroes(long, @adims[1..$#adims]); @adims = @adims[2..$#adims]; $info = @adims ? zeroes(long,@adims) : pdl(long,0); $a->sysv($uplo, $c, $ipiv, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msymsolve: Can't solve system of linear equations (after sytrf factorization): matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } wantarray ? ( ( $b->is_inplace(0) ? $b : $c->xchg(0,1)->sever ), $a, $ipiv, $info): $b->is_inplace(0) ? $b : $c->xchg(0,1)->sever; } sub PDL::Complex::msymsolve { my($a, $uplo, $b) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($ipiv, $info, $c); barf("msymsolve: Require square coefficient array(s)") unless( (@adims >= 3) && $adims[1] == $adims[2] ); barf("msymsolve: Require 2D right hand side array(s) B with number". " of row equal to order of A") unless( (@bdims >= 3)&& $bdims[2] == $adims[1]); barf("msymsolve: Require arrays with equal number of dimensions") if( @adims != @bdims); $uplo = 1 - $uplo; $a = $a->copy; $c = $b->is_inplace ? $b->xchg(1,2) : $b->xchg(1,2)->copy; $ipiv = zeroes(long, @adims[2..$#adims]); @adims = @adims[3..$#adims]; $info = @adims ? zeroes(long,@adims) : pdl(long,0); $a->csysv($uplo, $c, $ipiv, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msymsolve: Can't solve system of linear equations (after csytrf factorization): matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } wantarray ? ( ( $b->is_inplace(0) ? $b : $c->xchg(1,2)->sever ), $a, $ipiv, $info): $b->is_inplace(0) ? $b : $c->xchg(1,2)->sever; } =head2 msymsolvex =for ref Solves linear system of equations using diagonal pivoting method with symmetric matrix A. A * X = B Uses L or L from Lapack. Works on transposed array. =for usage (PDL, (HASH(result))) = msymsolvex(PDL(A), SCALAR (uplo), PDL(B), SCALAR(d)) uplo : UPPER = 0 | LOWER = 1, default = 0 d : whether return diagonal matrix d and pivot vector FALSE = 0 | TRUE = 1, default = 0 Returned values: X (SCALAR CONTEXT), HASH{'D'}: Block diagonal matrix D (and the multipliers) (if requested) HASH{'pivot'}: Pivot indice from LU factorization (if requested) HASH{'rcondition'}: Reciprocal condition of the matrix HASH{'ferror'}: Forward error bound HASH{'berror'}: Componentwise relative backward error HASH{'info'}: Info: output from sysvx =for example # Assume $a is symmetric my $a = random(10,10); my $b = random(5,10); my ($X, %result) = msolvex($a, 0, $b); =cut *msymsolvex = \&PDL::msymsolvex; sub PDL::msymsolvex { my($a, $uplo, $b, $d) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ( $af, $x, $ipiv, $info, $berr, $ferr, $rcond, %result); barf("msymsolvex: Require a square coefficient matrix") unless( ((@adims == 2) || (@adims == 3)) && $adims[-1] == $adims[-2] ); barf("msymsolvex: Require a right hand side matrix B with number". " of row equal to order of A") unless( ((@bdims == 2) || (@bdims == 3))&& $bdims[-1] == $adims[-2]); $uplo = 1 - $uplo; $b = $b->t; $x = PDL::zeroes $b; $af = PDL::zeroes $a; $info = pdl(long, 0); $rcond = null; $ipiv = zeroes(long, $adims[-2]); $ferr = zeroes($b->type, $bdims[-2]); $berr = zeroes($b->type, $bdims[-2]); (@adims == 3) ? $a->csysvx($uplo, (pdl(long, 0)), $b, $af, $ipiv, $x, $rcond, $ferr, $berr, $info) : $a->sysvx($uplo, (pdl(long, 0)), $b, $af, $ipiv, $x, $rcond, $ferr, $berr, $info); if( $info < $adims[-2] && $info > 0){ $info--; laerror("msymsolvex: Can't solve system of linear equations:\nfactor D($info,$info)". " of coefficient matrix is exactly 0"); } elsif ($info != 0 and $_laerror){ warn("msymsolvex: The matrix is singular to working precision"); } $result{rcondition} = $rcond; $result{ferror} = $ferr; $result{berror} = $berr; $result{info} = $info; if ($d){ $result{D} = $af; $result{pivot} = $ipiv; } wantarray ? ($x->xchg(-2,-1)->sever, %result): $x->xchg(-2,-1)->sever; } =head2 mpossolve =for ref Solves linear system of equations using Cholesky decomposition with symmetric positive definite matrix A. A * X = B Returns X in scalar context else X, U or L and info. B is overwritten by X if its inplace flag is set. Supports threading. Uses L or L from Lapack. Works on transposed array(s). =for usage (PDL, (PDL, PDL, PDL)) = mpossolve(PDL(A), SCALAR(uplo), PDL(B) ) uplo : UPPER = 0 | LOWER = 1, default = 0 =for example # asume $a is symmetric positive definite my $a = random(5,5); my $b = random(5,10); my $X = mpossolve($a, 0, $b); =cut sub mpossolve{ my $m = shift; $m->mpossolve(@_); } sub PDL::mpossolve { my($a, $uplo, $b) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($info, $c); barf("mpossolve: Require square coefficient array(s)") unless( (@adims >= 2) && $adims[0] == $adims[1] ); barf("mpossolve: Require right hand side array(s) B with number". " of row equal to order of A") unless( (@bdims >= 2)&& $bdims[1] == $adims[0]); barf("mpossolve: Require arrays with equal number of dimensions") if( @adims != @bdims); $uplo = 1 - $uplo; $a = $a->copy; $c = $b->is_inplace ? $b->xchg(0,1) : $b->xchg(0,1)->copy; @adims = @adims[2..$#adims]; $info = @adims ? zeroes(long,@adims) : pdl(long,0); $a->posv($uplo, $c, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mpossolve: Can't solve system of linear equations: matrix (PDL(s) @list) is/are not positive definite(s): \$info = $info"); } wantarray ? $b->is_inplace(0) ? ($b, $a,$info) : ($c->xchg(0,1)->sever , $a,$info) : $b->is_inplace(0) ? $b : $c->xchg(0,1)->sever; } sub PDL::Complex::mpossolve { my($a, $uplo, $b) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($info, $c); barf("mpossolve: Require square coefficient array(s)") unless( (@adims >= 3) && $adims[1] == $adims[2] ); barf("mpossolve: Require right hand side array(s) B with number". " of row equal to order of A") unless( (@bdims >= 3)&& $bdims[2] == $adims[1]); barf("mpossolve: Require arrays with equal number of dimensions") if( @adims != @bdims); $uplo = 1 - $uplo; $a = $a->copy; $c = $b->is_inplace ? $b->xchg(1,2) : $b->xchg(1,2)->copy; @adims = @adims[3..$#adims]; $info = @adims ? zeroes(long,@adims) : pdl(long,0); $a->cposv($uplo, $c, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mpossolve: Can't solve system of linear equations: matrix (PDL(s) @list) is/are not positive definite(s): \$info = $info"); } wantarray ? $b->is_inplace(0) ? ($b, $a,$info) : ($c->xchg(1,2)->sever , $a,$info) : $b->is_inplace(0) ? $b : $c->xchg(1,2)->sever; } =head2 mpossolvex =for ref Solves linear system of equations using Cholesky decomposition with symmetric positive definite matrix A A * X = B Can optionnally equilibrate the matrix. Uses L or L from Lapack. Works on transposed array(s). =for usage (PDL, (HASH(result))) = mpossolvex(PDL(A), SCARA(uplo), PDL(B), HASH(options)) uplo : UPPER = 0 | LOWER = 1, default = 0 where options are: equilibrate: equilibrates A if necessary. form equilibration is returned in HASH{'equilibration'}: 0: no equilibration 1: equilibration scale factors are returned in HASH{'scale'} 0: false 1: true U|L: returns Cholesky factorization in HASH{U} or HASH{L} 0: false 1: true A: returns scaled A if equilibration was done in HASH{A} 0: false 1: true B: returns scaled B if equilibration was done in HASH{B} 0: false 1: true Returned values: X (SCALAR CONTEXT), HASH{'rcondition'}: Reciprocal condition of the matrix HASH{'ferror'}: Forward error bound HASH{'berror'}: Componentwise relative backward error HASH{'info'}: Info: output from gesvx =for example # Assume $a is symmetric positive definite my $a = random(10,10); my $b = random(5,10); my %options = (U=>1, equilibrate => 1, ); my ($X, %result) = msolvex($a, 0, $b,%opt); =cut *mpossolvex = \&PDL::mpossolvex; sub PDL::mpossolvex { my($a, $uplo, $b, %opt) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ( $af, $x, $info, $equilibrate, $berr, $ferr, $rcond, $equed, %result, $s); barf("mpossolvex: Require a square coefficient matrix") unless( ((@adims == 2) || (@adims == 3)) && $adims[-1] == $adims[-2] ); barf("mpossolvex: Require a 2D right hand side matrix B with number". " of row equal to order of A") unless( ((@bdims == 2) || (@bdims == 3))&& $bdims[-1] == $adims[-2]); $uplo = $uplo ? pdl(long, 0): pdl(long, 1); $equilibrate = $opt{'equilibrate'} ? pdl(long, 2): pdl(long,1); $a = $a->copy; $b = $b->t->copy; $x = PDL::zeroes $b; $af = PDL::zeroes $a; $info = pdl(long, 0); $rcond = null; $equed = pdl(long, 0); $s = zeroes($a->type, $adims[-2]); $ferr = zeroes($b->type, $bdims[-2]); $berr = zeroes($b->type, $bdims[-2]); (@adims == 3) ? $a->cposvx($uplo, $equilibrate, $b, $af, $equed, $s, $x, $rcond, $ferr, $berr, $info) : $a->posvx($uplo, $equilibrate, $b, $af, $equed, $s, $x, $rcond, $ferr, $berr, $info); if( $info < $adims[-2] && $info > 0){ $info--; barf("mpossolvex: Can't solve system of linear equations:\n". "the leading minor of order $info of A is". " not positive definite"); return; } elsif ( $info and $_laerror){ warn("mpossolvex: The matrix is singular to working precision"); } $result{rcondition} = $rcond; $result{ferror} = $ferr; $result{berror} = $berr; if ($opt{equilibrate}){ $result{equilibration} = $equed; if ($equed){ $result{scale} = $s if $equed; $result{A} = $a if $opt{A}; $result{B} = $b->xchg(-2,-1)->sever if $opt{B}; } } $result{info} = $info; $result{L} = $af if $opt{L}; $result{U} = $af if $opt{U}; wantarray ? ($x->xchg(-2,-1)->sever, %result): $x->xchg(-2,-1)->sever; } =head2 mlls =for ref Solves overdetermined or underdetermined real linear systems using QR or LQ factorization. If M > N in the M-by-N matrix A, returns the residual sum of squares too. Uses L or L from Lapack. Works on transposed arrays. =for usage PDL(X) = mlls(PDL(A), PDL(B), SCALAR(trans)) trans : NOTRANSPOSE = 0 | TRANSPOSE/CONJUGATE = 1, default = 0 =for example $a = random(4,5); $b = random(3,5); ($x, $res) = mlls($a, $b); =cut *mlls = \&PDL::mlls; sub PDL::mlls { my($a, $b, $trans) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($info, $x, $type); barf("mlls: Require a matrix") unless( @adims == 2 || @adims == 3); barf("mlls: Require a 2D right hand side matrix B with number". " of rows equal to number of rows of A") unless( (@bdims == 2 || @bdims == 3)&& $bdims[-1] == $adims[-1]); $a = $a->copy; $type = $a->type; if ( $adims[-1] < $adims[-2]){ if (@adims == 3){ $x = PDL::new_from_specification('PDL::Complex', $type, 2,$adims[1], $bdims[1]); $x(, :($bdims[2]-1), :($bdims[1]-1)) .= $b->xchg(1,2); } else{ $x = PDL::new_from_specification('PDL', $type, $adims[0], $bdims[0]); $x(:($bdims[1]-1), :($bdims[0]-1)) .= $b->xchg(0,1); } } else{ $x = $b->xchg(-2,-1)->copy; } $info = pdl(long,0); if (@adims == 3){ $trans ? $a->xchg(1,2)->cgels(1, $x, $info) : $a->xchg(1,2)->cgels(0, $x, $info); } else{ $trans ? $a->gels(0, $x, $info) : $a->gels(1, $x, $info); } $x = $x->xchg(-2,-1); if ( $adims[-1] <= $adims[-2]){ return $x->sever; } if(@adims == 2){ wantarray ? return($x(, :($adims[0]-1))->sever, $x(, $adims[0]:)->xchg(0,1)->pow(2)->sumover) : return $x(, :($adims[0]-1))->sever; } else{ wantarray ? return($x(,, :($adims[1]-1))->sever, PDL::Ufunc::sumover(PDL::Complex::Cpow($x(,, $adims[1]:),pdl($type,2,0))->reorder(2,0,1))) : return $x(,, :($adims[1]-1))->sever; } } =head2 mllsy =for ref Computes the minimum-norm solution to a real linear least squares problem using a complete orthogonal factorization. Uses L or L from Lapack. Works on tranposed arrays. =for usage ( PDL(X), ( HASH(result) ) ) = mllsy(PDL(A), PDL(B)) Returned values: X (SCALAR CONTEXT), HASH{'A'}: complete orthogonal factorization of A HASH{'jpvt'}: details of columns interchanges HASH{'rank'}: effective rank of A =for example my $a = random(10,10); my $b = random(10,10); $X = mllsy($a, $b); =cut *mllsy = \&PDL::mllsy; sub PDL::mllsy { my($a, $b) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($info, $x, $rcond, $rank, $jpvt, $type); barf("mllsy: Require a matrix") unless( @adims == 2 || @adims == 3); barf("mllsy: Require a 2D right hand side matrix B with number". " of rows equal to number of rows of A") unless( (@bdims == 2 || @bdims == 3)&& $bdims[-1] == $adims[-1]); $type = $a->type; $rcond = lamch(pdl($type,0)); $rcond = $rcond->sqrt - ($rcond->sqrt - $rcond) / 2; $a = $a->xchg(-2,-1)->copy; if ( $adims[1] < $adims[0]){ if (@adims == 3){ $x = PDL::new_from_specification('PDL::Complex', $type, 2, $adims[1], $bdims[1]); $x(, :($bdims[2]-1), :($bdims[1]-1)) .= $b->xchg(1,2); } else{ $x = PDL::new_from_specification('PDL', $type, $adims[0], $bdims[0]); $x(:($bdims[1]-1), :($bdims[0]-1)) .= $b->xchg(0,1); } } else{ $x = $b->xchg(-2,-1)->copy; } $info = pdl(long,0); $rank = null; $jpvt = zeroes(long, $adims[-2]); (@adims == 3) ? $a->cgelsy($x, $rcond, $jpvt, $rank, $info) : $a->gelsy($x, $rcond, $jpvt, $rank, $info); if ( $adims[-1] <= $adims[-2]){ wantarray ? return ($x->xchg(-2,-1)->sever, ('A'=> $a->xchg(-2,-1)->sever, 'rank' => $rank, 'jpvt'=>$jpvt)) : return $x->xchg(-2,-1)->sever; } if (@adims == 3){ wantarray ? return ($x->xchg(1,2)->(,, :($adims[1]-1))->sever, ('A'=> $a->xchg(1,2)->sever, 'rank' => $rank, 'jpvt'=>$jpvt)) : $x->xchg(1,2)->(, :($adims[1]-1))->sever; } else{ wantarray ? return ($x->xchg(0,1)->(, :($adims[0]-1))->sever, ('A'=> $a->xchg(0,1)->sever, 'rank' => $rank, 'jpvt'=>$jpvt)) : $x->xchg(0,1)->(, :($adims[0]-1))->sever; } } =head2 mllss =for ref Computes the minimum-norm solution to a real linear least squares problem using a singular value decomposition. Uses L or L from Lapack. Works on transposed arrays. =for usage ( PDL(X), ( HASH(result) ) )= mllss(PDL(A), PDL(B), SCALAR(method)) method: specifie which method to use (see Lapack for further details) '(c)gelss' or '(c)gelsd', default = '(c)gelsd' Returned values: X (SCALAR CONTEXT), HASH{'V'}: if method = (c)gelss, the right singular vectors, stored columnwise HASH{'s'}: singular values from SVD HASH{'res'}: if A has full rank the residual sum-of-squares for the solution HASH{'rank'}: effective rank of A HASH{'info'}: info output from method =for example my $a = random(10,10); my $b = random(10,10); $X = mllss($a, $b); =cut *mllss = \&PDL::mllss; sub PDL::mllss { my($a, $b, $method) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($info, $x, $rcond, $rank, $s, $min, $type); barf("mllss: Require a matrix") unless( @adims == 2 || @adims == 3); barf("mllss: Require a 2D right hand side matrix B with number". " of rows equal to number of rows of A") unless( (@bdims == 2 || @bdims == 3)&& $bdims[-1] == $adims[-1]); $type = $a->type; #TODO: Add this in option $rcond = lamch(pdl($type,0)); $rcond = $rcond->sqrt - ($rcond->sqrt - $rcond) / 2; $a = $a->xchg(-2,-1)->copy; if ($adims[1] < $adims[0]){ if (@adims == 3){ $x = PDL::new_from_specification('PDL::Complex', $type, 2, $adims[1], $bdims[1]); $x(, :($bdims[2]-1), :($bdims[1]-1)) .= $b->xchg(1,2); } else{ $x = PDL::new_from_specification('PDL', $type, $adims[0], $bdims[0]); $x(:($bdims[1]-1), :($bdims[0]-1)) .= $b->xchg(0,1); } } else{ $x = $b->xchg(-2,-1)->copy; } $info = pdl(long,0); $rank = null; $min = ($adims[-2] > $adims[-1]) ? $adims[-1] : $adims[-2]; $s = zeroes($a->type, $min); unless ($method) { $method = (@adims == 3) ? 'cgelsd' : 'gelsd'; } $a->$method($x, $rcond, $s, $rank, $info); laerror("mllss: The algorithm for computing the SVD failed to converge\n") if $info; $x = $x->xchg(-2,-1); if ( $adims[-1] <= $adims[-2]){ if (wantarray){ $method =~ /gelsd/ ? return ($x->sever, ('rank' => $rank, 's'=>$s, 'info'=>$info)): (return ($x, ('V'=> $a, 'rank' => $rank, 's'=>$s, 'info'=>$info)) ); } else{return $x;} } elsif (wantarray){ if ($rank == $min){ if (@adims == 3){ my $res = PDL::Ufunc::sumover(PDL::Complex::Cpow($x(,, $adims[1]:),pdl($type,2,0))->reorder(2,0,1)); if ($method =~ /gelsd/){ return ($x(,, :($adims[1]-1))->sever, ('res' => $res, 'rank' => $rank, 's'=>$s, 'info'=>$info)); } else{ return ($x(,, :($adims[1]-1))->sever, ('res' => $res, 'V'=> $a, 'rank' => $rank, 's'=>$s, 'info'=>$info)); } } else{ my $res = $x(, $adims[0]:)->xchg(0,1)->pow(2)->sumover; if ($method =~ /gelsd/){ return ($x(, :($adims[0]-1))->sever, ('res' => $res, 'rank' => $rank, 's'=>$s, 'info'=>$info)); } else{ return ($x(, :($adims[0]-1))->sever, ('res' => $res, 'V'=> $a, 'rank' => $rank, 's'=>$s, 'info'=>$info)); } } } else { if (@adims == 3){ $method =~ /gelsd/ ? return ($x(,, :($adims[1]-1))->sever, ('rank' => $rank, 's'=>$s, 'info'=>$info)) : ($x(,, :($adims[1]-1))->sever, ('v'=> $a, 'rank' => $rank, 's'=>$s, 'info'=>$info)); } else{ $method =~ /gelsd/ ? return ($x(, :($adims[0]-1))->sever, ('rank' => $rank, 's'=>$s, 'info'=>$info)) : ($x(, :($adims[0]-1))->sever, ('v'=> $a, 'rank' => $rank, 's'=>$s, 'info'=>$info)); } } } else{return (@adims == 3) ? $x(,, :($adims[1]-1))->sever : $x(, :($adims[0]-1))->sever;} } =head2 mglm =for ref Solves a general Gauss-Markov Linear Model (GLM) problem. Supports threading. Uses L or L from Lapack. Works on transposed arrays. =for usage (PDL(x), PDL(y)) = mglm(PDL(a), PDL(b), PDL(d)) where d is the left hand side of the GLM equation =for example my $a = random(8,10); my $b = random(7,10); my $d = random(10); my ($x, $y) = mglm($a, $b, $d); =cut sub mglm{ my $m = shift; $m->mglm(@_); } sub PDL::mglm{ my($a, $b, $d) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my(@ddims) = $d->dims; my($x, $y, $info); barf("mglm: Require arrays with equal number of rows") unless( @adims >= 2 && @bdims >= 2 && $adims[1] == $bdims[1]); barf "mglm: Require that column(A) <= row(A) <= column(A) + column(B)" unless ( ($adims[0] <= $adims[1] ) && ($adims[1] <= ($adims[0] + $bdims[0])) ); barf("mglm: Require vector(s) with size equal to number of rows of A") unless( @ddims >= 1 && $adims[1] == $ddims[0]); $a = $a->xchg(0,1)->copy; $b = $b->xchg(0,1)->copy; $d = $d->copy; ($x, $y, $info) = $a->ggglm($b, $d); $x, $y; } sub PDL::Complex::mglm { my($a, $b, $d) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my(@ddims) = $d->dims; my($x, $y, $info); barf("mglm: Require arrays with equal number of rows") unless( @adims >= 3 && @bdims >= 3 && $adims[2] == $bdims[2]); barf "mglm: Require that column(A) <= row(A) <= column(A) + column(B)" unless ( ($adims[2] <= $adims[2] ) && ($adims[2] <= ($adims[1] + $bdims[1])) ); barf("mglm: Require vector(s) with size equal to number of rows of A") unless( @ddims >= 2 && $adims[2] == $ddims[1]); $a = $a->xchg(1,2)->copy; $b = $b->xchg(1,2)->copy; $d = $d->copy; ($x, $y, $info) = $a->cggglm($b, $d); $x, $y; } =head2 mlse =for ref Solves a linear equality-constrained least squares (LSE) problem. Uses L or L from Lapack. Works on transposed arrays. =for usage (PDL(x), PDL(res2)) = mlse(PDL(a), PDL(b), PDL(c), PDL(d)) where c : The right hand side vector for the least squares part of the LSE problem. d : The right hand side vector for the constrained equation. x : The solution of the LSE problem. res2 : The residual sum of squares for the solution (returned only in array context) =for example my $a = random(5,4); my $b = random(5,3); my $c = random(4); my $d = random(3); my ($x, $res2) = mlse($a, $b, $c, $d); =cut *mlse = \&PDL::mlse; sub PDL::mlse { my($a, $b, $c, $d) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my(@cdims) = $c->dims; my(@ddims) = $d->dims; my($x, $info); barf("mlse: Require 2 matrices with equal number of columns") unless( ((@adims == 2 && @bdims == 2)||(@adims == 3 && @bdims == 3)) && $adims[-2] == $bdims[-2]); barf("mlse: Require 1D vector C with size equal to number of A rows") unless( (@cdims == 1 || @cdims == 2)&& $adims[-1] == $cdims[-1]); barf("mlse: Require 1D vector D with size equal to number of B rows") unless( (@ddims == 1 || @ddims == 2)&& $bdims[-1] == $ddims[-1]); barf "mlse: Require that row(B) <= column(A) <= row(A) + row(B)" unless ( ($bdims[-1] <= $adims[-2] ) && ($adims[-2] <= ($adims[-1]+ $bdims[-1])) ); $a = $a->xchg(-2,-1)->copy; $b = $b->xchg(-2,-1)->copy; $c = $c->copy; $d = $d->copy; ($x , $info) = (@adims == 3) ? $a->cgglse($b, $c, $d) : $a->gglse($b, $c, $d); if (@adims == 3){ wantarray ? ($x, PDL::Ufunc::sumover(PDL::Complex::Cpow($c(,($adims[1]-$bdims[2]):($adims[2]-1)),pdl($a->type,2,0))->xchg(0,1))) : $x; } else{ wantarray ? ($x, $c(($adims[0]-$bdims[1]):($adims[1]-1))->pow(2)->sumover) : $x; } } =head2 meigen =for ref Computes eigenvalues and, optionally, the left and/or right eigenvectors of a general square matrix (spectral decomposition). Eigenvectors are normalized (Euclidean norm = 1) and largest component real. The eigenvalues and eigenvectors returned are object of type PDL::Complex. If only eigenvalues are requested, info is returned in array context. Supports threading. Uses L or L from Lapack. Works on transposed arrays. =for usage (PDL(values), (PDL(LV), (PDL(RV)), (PDL(info))) = meigen(PDL, SCALAR(left vector), SCALAR(right vector)) left vector : FALSE = 0 | TRUE = 1, default = 0 right vector : FALSE = 0 | TRUE = 1, default = 0 =for example my $a = random(10,10); my ( $eigenvalues, $left_eigenvectors, $right_eigenvectors ) = meigen($a,1,1); =cut sub meigen{ my $m = shift; $m->meigen(@_); } sub PDL::meigen { my($m,$jobvl,$jobvr) = @_; my(@dims) = $m->dims; barf("meigen: Require square array(s)") unless( @dims >= 2 && $dims[0] == $dims[1]); my ($w, $vl, $vr, $info, $type, $wr, $wi); $type = $m->type; $info = null; $wr = null; $wi = null; $vl = $jobvl ? PDL::new_from_specification('PDL', $type, @dims) : pdl($type,0); $vr = $jobvr ? PDL::new_from_specification('PDL', $type, @dims) : pdl($type,0); $m->xchg(0,1)->geev( $jobvl,$jobvr, $wr, $wi, $vl, $vr, $info); if ($jobvl){ ($w, $vl) = cplx_eigen((bless $wr, 'PDL::Complex'), $wi, $vl, 1); } if ($jobvr){ ($w, $vr) = cplx_eigen((bless $wr, 'PDL::Complex'), $wi, $vr, 1); } $w = PDL::Complex::ecplx( $wr, $wi ) unless $jobvr || $jobvl; if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("meigen: The QR algorithm failed to converge for PDL(s) @list: \$info = $info"); print ("Returning converged eigenvalues\n"); } $jobvl? $jobvr ? ($w, $vl->xchg(1,2)->sever, $vr->xchg(1,2)->sever, $info):($w, $vl->xchg(1,2)->sever, $info) : $jobvr? ($w, $vr->xchg(1,2)->sever, $info) : wantarray ? ($w, $info) : $w; } sub PDL::Complex::meigen { my($m,$jobvl,$jobvr) = @_; my(@dims) = $m->dims; barf("meigen: Require square array(s)") unless( @dims >= 3 && $dims[1] == $dims[2]); my ($w, $vl, $vr, $info, $type); $type = $m->type; $info = null; $w = PDL::Complex->null; #PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1]); $vl = $jobvl ? PDL::new_from_specification('PDL::Complex', $type, @dims) : pdl($type,[0,0]); $vr = $jobvr ? PDL::new_from_specification('PDL::Complex', $type, @dims) : pdl($type,[0,0]); $m->xchg(1,2)->cgeev( $jobvl,$jobvr, $w, $vl, $vr, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("meigen: The QR algorithm failed to converge for PDL(s) @list: \$info = $info"); print ("Returning converged eigenvalues\n"); } $jobvl? $jobvr ? ($w, $vl->xchg(1,2)->sever, $vr->xchg(1,2)->sever, $info):($w, $vl->xchg(1,2)->sever, $info) : $jobvr? ($w, $vr->xchg(1,2)->sever, $info) : wantarray ? ($w, $info) : $w; } =head2 meigenx =for ref Computes eigenvalues, one-norm and, optionally, the left and/or right eigenvectors of a general square matrix (spectral decomposition). Eigenvectors are normalized (Euclidean norm = 1) and largest component real. The eigenvalues and eigenvectors returned are object of type PDL::Complex. Uses L or L from Lapack. Works on transposed arrays. =for usage (PDL(value), (PDL(lv), (PDL(rv)), HASH(result)), HASH(result)) = meigenx(PDL, HASH(options)) where options are: vector: eigenvectors to compute 'left': computes left eigenvectors 'right': computes right eigenvectors 'all': computes left and right eigenvectors 0: doesn't compute (default) rcondition: reciprocal condition numbers to compute (returned in HASH{'rconde'} for eigenvalues and HASH{'rcondv'} for eigenvectors) 'value': computes reciprocal condition numbers for eigenvalues 'vector': computes reciprocal condition numbers for eigenvectors 'all': computes reciprocal condition numbers for eigenvalues and eigenvectors 0: doesn't compute (default) error: specifie whether or not it computes the error bounds (returned in HASH{'eerror'} and HASH{'verror'}) error bound = EPS * One-norm / rcond(e|v) (reciprocal condition numbers for eigenvalues or eigenvectors must be computed). 1: returns error bounds 0: not computed scale: specifie whether or not it diagonaly scales the entry matrix (scale details returned in HASH : 'scale') 1: scales 0: Doesn't scale (default) permute: specifie whether or not it permutes row and columns (permute details returned in HASH{'balance'}) 1: permutes 0: Doesn't permute (default) schur: specifie whether or not it returns the Schur form (returned in HASH{'schur'}) 1: returns Schur form 0: not returned Returned values: eigenvalues (SCALAR CONTEXT), left eigenvectors if requested, right eigenvectors if requested, HASH{'norm'}: One-norm of the matrix HASH{'info'}: Info: if > 0, the QR algorithm failed to compute all the eigenvalues (see syevx for further details) =for example my $a = random(10,10); my %options = ( rcondition => 'all', vector => 'all', error => 1, scale => 1, permute=>1, shur => 1 ); my ( $eigenvalues, $left_eigenvectors, $right_eigenvectors, %result) = meigenx($a,%options); print "Error bounds for eigenvalues:\n $eigenvalues\n are:\n". transpose($result{'eerror'}) unless $info; =cut *meigenx = \&PDL::meigenx; sub PDL::meigenx { my($m, %opt) = @_; my(@dims) = $m->dims; barf("meigenx: Require a square matrix") unless( ( (@dims == 2)|| (@dims == 3) )&& $dims[-1] == $dims[-2]); my (%result, $jobvl, $jobvr, $sense, $balanc, $vr, $vl, $rconde, $rcondv, $w, $info, $ilo, $ihi, $scale, $abnrm, $type); $type = $m->type; $info = null; $ilo = null; $ihi = null; $abnrm = null; $balanc = ($opt{'permute'} && $opt{'scale'} ) ? 3 : $opt{'permute'} ? 1 : $opt{'scale'} ? 2:0; if (@dims == 3){ $m = $m->copy; $w = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1]); $scale = PDL::new_from_specification('PDL', $type, $dims[1]); if ($opt{'vector'} eq 'left' || $opt{'vector'} eq 'all' || $opt{'rcondition'} ){ $jobvl = 1; $vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]); } else{ $jobvl = 0; $vl = pdl($type,[0,0]); } if ($opt{'vector'} eq 'right' || $opt{'vector'} eq 'all' || $opt{'rcondition'} ){ $jobvr = 1; $vr = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]); } else{ $jobvr = 0; $vr = pdl($type,[0,0]); } if ( $opt{'rcondition'} eq 'value'){ $sense = 1; $rconde = PDL::new_from_specification('PDL', $type, $dims[1]); $rcondv = pdl($type,0); } elsif( $opt{'rcondition'} eq 'vector'){ $sense = 2; $rcondv = PDL::new_from_specification('PDL', $type, $dims[1]); $rconde = pdl($type,0); } elsif( $opt{'rcondition'} eq 'all' ){ $sense = 3; $rcondv = PDL::new_from_specification('PDL', $type, $dims[1]); $rconde = PDL::new_from_specification('PDL', $type, $dims[1]); } else{ $sense = 0; $rconde = pdl($type,0); $rcondv = pdl($type,0); } $m->xchg(1,2)->cgeevx( $jobvl, $jobvr, $balanc,$sense,$w, $vl, $vr, $ilo, $ihi, $scale, $abnrm, $rconde, $rcondv, $info); } else{ my ($wr, $wi); $m = $m->copy; $wr = PDL::new_from_specification('PDL', $type, $dims[0]); $wi = PDL::new_from_specification('PDL', $type, $dims[0]); $scale = PDL::new_from_specification('PDL', $type, $dims[0]); if ($opt{'vector'} eq 'left' || $opt{'vector'} eq 'all' || $opt{'rcondition'} ){ $jobvl = 1; $vl = PDL::new_from_specification('PDL', $type, $dims[0], $dims[0]); } else{ $jobvl = 0; $vl = pdl($type, 0); } if ($opt{'vector'} eq 'right' || $opt{'vector'} eq 'all' || $opt{'rcondition'} ){ $jobvr = 1; $vr = PDL::new_from_specification('PDL', $type, $dims[0], $dims[0]); } else{ $jobvr = 0; $vr = pdl($type,0); } if ( $opt{'rcondition'} eq 'value'){ $sense = 1; $rconde = PDL::new_from_specification('PDL', $type, $dims[0]); $rcondv = pdl($type, 0); } elsif( $opt{'rcondition'} eq 'vector'){ $sense = 2; $rcondv = PDL::new_from_specification('PDL', $type, $dims[0]); $rconde = pdl($type, 0); } elsif( $opt{'rcondition'} eq 'all' ){ $sense = 3; $rcondv = PDL::new_from_specification('PDL', $type, $dims[0]); $rconde = PDL::new_from_specification('PDL', $type, $dims[0]); } else{ $sense = 0; $rconde = pdl($type, 0); $rcondv = pdl($type, 0); } $m->xchg(0,1)->geevx( $jobvl, $jobvr, $balanc,$sense,$wr, $wi, $vl, $vr, $ilo, $ihi, $scale, $abnrm, $rconde, $rcondv, $info); if ($jobvl){ ($w, $vl) = cplx_eigen((bless $wr, 'PDL::Complex'), $wi, $vl, 1); } if ($jobvr){ ($w, $vr) = cplx_eigen((bless $wr, 'PDL::Complex'), $wi, $vr, 1); } $w = PDL::Complex::complex t(cat $wr, $wi) unless $jobvr || $jobvl; } if ($info){ laerror("meigenx: The QR algorithm failed to converge"); print "Returning converged eigenvalues\n" if $_laerror; } $result{'schur'} = $m if $opt{'schur'}; if ($opt{'permute'}){ my $balance = cat $ilo, $ihi; $result{'balance'} = $balance; } $result{'info'} = $info; $result{'scale'} = $scale if $opt{'scale'}; $result{'norm'} = $abnrm; if ( $opt{'rcondition'} eq 'vector' || $opt{'rcondition'} eq "all"){ $result{'rcondv'} = $rcondv; $result{'verror'} = (lamch(pdl($type,0))* $abnrm /$rcondv ) if $opt{'error'}; } if ( $opt{'rcondition'} eq 'value' || $opt{'rcondition'} eq "all"){ $result{'rconde'} = $rconde; $result{'eerror'} = (lamch(pdl($type,0))* $abnrm /$rconde ) if $opt{'error'}; } if ($opt{'vector'} eq "left"){ return ($w, $vl->xchg(-2,-1)->sever, %result); } elsif ($opt{'vector'} eq "right"){ return ($w, $vr->xchg(-2,-1)->sever, %result); } elsif ($opt{'vector'} eq "all"){ $w, $vl->xchg(-2,-1)->sever, $vr->xchg(-2,-1)->sever, %result; } else{ return ($w, %result); } } =head2 mgeigen =for ref Computes generalized eigenvalues and, optionally, the left and/or right generalized eigenvectors for a pair of N-by-N real nonsymmetric matrices (A,B) . The alpha from ratio alpha/beta is object of type PDL::Complex. Supports threading. Uses L or L from Lapack. Works on transposed arrays. =for usage ( PDL(alpha), PDL(beta), ( PDL(LV), (PDL(RV) ), PDL(info)) = mgeigen(PDL(A),PDL(B) SCALAR(left vector), SCALAR(right vector)) left vector : FALSE = 0 | TRUE = 1, default = 0 right vector : FALSE = 0 | TRUE = 1, default = 0 =for example my $a = random(10,10); my $b = random(10,10); my ( $alpha, $beta, $left_eigenvectors, $right_eigenvectors ) = mgeigen($a, $b,1, 1); =cut sub mgeigen{ my $m = shift; $m->mgeigen(@_); } sub PDL::mgeigen { my($a, $b,$jobvl,$jobvr) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; barf("mgeigen: Require 2 square matrices of same order") unless( @adims >= 2 && $adims[0] == $adims[1] && @bdims >= 2 && $bdims[0] == $bdims[1] && $adims[0] == $bdims[0]); barf("mgeigen: Require matrices with equal number of dimensions") if( @adims != @bdims); my ($vl, $vr, $info, $beta, $type, $wtmp); $type = $a->type; my ($w,$wi); $b = $b->xchg(0,1); $wtmp = null; $wi = null; $beta = null; $vl = $jobvl ? PDL::zeroes $a : pdl($type,0); $vr = $jobvr ? PDL::zeroes $a : pdl($type,0); $info = null; $a->xchg(0,1)->ggev($jobvl,$jobvr, $b, $wtmp, $wi, $beta, $vl, $vr, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mgeigen: Can't compute eigenvalues/vectors for PDL(s) @list: \$info = $info"); } $w = PDL::Complex::ecplx ($wtmp, $wi); if ($jobvl){ (undef, $vl) = cplx_eigen((bless $wtmp, 'PDL::Complex'), $wi, $vl, 1); } if ($jobvr){ (undef, $vr) = cplx_eigen((bless $wtmp, 'PDL::Complex'), $wi, $vr, 1); } $jobvl? $jobvr? ($w, $beta, $vl->xchg(1,2)->sever, $vr->xchg(1,2)->sever, $info):($w, $beta, $vl->xchg(1,2)->sever, $info) : $jobvr? ($w, $beta, $vr->xchg(1,2)->sever, $info): ($w, $beta, $info); } sub PDL::Complex::mgeigen { my($a, $b,$jobvl,$jobvr) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my ($vl, $vr, $info, $beta, $type, $eigens); $type = $a->type; barf("mgeigen: Require 2 square matrices of same order") unless( @adims >= 3 && $adims[1] == $adims[2] && @bdims >= 3 && $bdims[1] == $bdims[2] && $adims[1] == $bdims[1]); barf("mgeigen: Require matrices with equal number of dimensions") if( @adims != @bdims); $b = $b->xchg(1,2); $eigens = PDL::Complex->null; $beta = PDL::Complex->null; $vl = $jobvl ? PDL::zeroes $a : pdl($type,[0,0]); $vr = $jobvr ? PDL::zeroes $a : pdl($type,[0,0]); $info = null; $a->xchg(1,2)->cggev($jobvl,$jobvr, $b, $eigens, $beta, $vl, $vr, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mgeigen: Can't compute eigenvalues/vectors for PDL(s) @list: \$info = $info"); } $jobvl? $jobvr? ($eigens, $beta, $vl->xchg(1,2)->sever, $vr->xchg(1,2)->sever, $info):($eigens, $beta, $vl->xchg(1,2)->sever, $info) : $jobvr? ($eigens, $beta, $vr->xchg(1,2)->sever, $info): ($eigens, $beta, $info); } =head2 mgeigenx =for ref Computes generalized eigenvalues, one-norms and, optionally, the left and/or right generalized eigenvectors for a pair of N-by-N real nonsymmetric matrices (A,B). The alpha from ratio alpha/beta is object of type PDL::Complex. Uses L or L from Lapack. Works on transposed arrays. =for usage (PDL(alpha), PDL(beta), PDL(lv), PDL(rv), HASH(result) ) = mgeigenx(PDL(a), PDL(b), HASH(options)) where options are: vector: eigenvectors to compute 'left': computes left eigenvectors 'right': computes right eigenvectors 'all': computes left and right eigenvectors 0: doesn't compute (default) rcondition: reciprocal condition numbers to compute (returned in HASH{'rconde'} for eigenvalues and HASH{'rcondv'} for eigenvectors) 'value': computes reciprocal condition numbers for eigenvalues 'vector': computes reciprocal condition numbers for eigenvectors 'all': computes reciprocal condition numbers for eigenvalues and eigenvectors 0: doesn't compute (default) error: specifie whether or not it computes the error bounds (returned in HASH{'eerror'} and HASH{'verror'}) error bound = EPS * sqrt(one-norm(a)**2 + one-norm(b)**2) / rcond(e|v) (reciprocal condition numbers for eigenvalues or eigenvectors must be computed). 1: returns error bounds 0: not computed scale: specifie whether or not it diagonaly scales the entry matrix (scale details returned in HASH : 'lscale' and 'rscale') 1: scales 0: doesn't scale (default) permute: specifie whether or not it permutes row and columns (permute details returned in HASH{'balance'}) 1: permutes 0: Doesn't permute (default) schur: specifie whether or not it returns the Schur forms (returned in HASH{'aschur'} and HASH{'bschur'}) (right or left eigenvectors must be computed). 1: returns Schur forms 0: not returned Returned values: alpha, beta, left eigenvectors if requested, right eigenvectors if requested, HASH{'anorm'}, HASH{'bnorm'}: One-norm of the matrix A and B HASH{'info'}: Info: if > 0, the QR algorithm failed to compute all the eigenvalues (see syevx for further details) =for example $a = random(10,10); $b = random(10,10); %options = (rcondition => 'all', vector => 'all', error => 1, scale => 1, permute=>1, shur => 1 ); ($alpha, $beta, $left_eigenvectors, $right_eigenvectors, %result) = mgeigenx($a, $b,%options); print "Error bounds for eigenvalues:\n $eigenvalues\n are:\n". transpose($result{'eerror'}) unless $info; =cut *mgeigenx = \&PDL::mgeigenx; sub PDL::mgeigenx { my($a, $b,%opt) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; my (%result, $jobvl, $jobvr, $sense, $balanc, $vr, $vl, $rconde, $rcondv, $wr, $wi, $beta, $info, $ilo, $ihi, $rscale, $lscale, $abnrm, $bbnrm, $type, $eigens); if (@adims ==3){ barf("mgeigenx: Require 2 square matrices of same order") unless( @adims == 3 && $adims[1] == $adims[2] && @bdims == 3 && $bdims[1] == $bdims[2] && $adims[1] == $bdims[1]); $a = $a->copy; $b = $b->xchg(-1,-2)->copy; $eigens = PDL::Complex->null; $beta = PDL::Complex->null; } else{ barf("mgeigenx: Require 2 square matrices of same order") unless( @adims == 2 && $adims[0] == $adims[1] && @bdims == 2 && $bdims[0] == $bdims[1] && $adims[0] == $bdims[0]); $a = $a->copy; $b = $b->xchg(0,1)->copy; $wr = null; $wi = null; $beta= null; } $type = $a->type; $info = null; $ilo = null; $ihi = null; $rscale = zeroes($type, $adims[-1]); $lscale = zeroes($type, $adims[-1]); $abnrm = null; $bbnrm = null; if ($opt{'vector'} eq 'left' || $opt{'vector'} eq 'all' || $opt{'rcondition'} ){ $jobvl = pdl(long,1); $vl = PDL::zeroes $a; } else{ $jobvl = pdl(long,0); $vl = pdl($type,0); } if ($opt{'vector'} eq 'right' || $opt{'vector'} eq 'all' || $opt{'rcondition'} ){ $jobvr = pdl(long,1); $vr = PDL::zeroes $a; } else{ $jobvr = pdl(long,0); $vr = pdl($type,0); } if ( $opt{'rcondition'} eq 'value'){ $sense = pdl(long,1); $rconde = zeroes($type, $adims[-1]); $rcondv = pdl($type,0); } elsif( $opt{'rcondition'} eq 'vector'){ $sense = pdl(long,2); $rcondv = zeroes($type, $adims[-1]); $rconde = pdl($type,0); } elsif( $opt{'rcondition'} eq 'all' ){ $sense = pdl(long,3); $rcondv = zeroes($type, $adims[-1]); $rconde = zeroes($type, $adims[-1]); } else{ $sense = pdl(long,0); $rconde = pdl($type,0); $rcondv = pdl($type,0); } $balanc = ($opt{'permute'} && $opt{'scale'} ) ? pdl(long,3) : $opt{'permute'} ? pdl(long,1) : $opt{'scale'} ? pdl(long,2) : pdl(long,0); if (@adims == 2){ $a->xchg(0,1)->ggevx($balanc, $jobvl, $jobvr, $sense, $b, $wr, $wi, $beta, $vl, $vr, $ilo, $ihi, $lscale, $rscale, $abnrm, $bbnrm, $rconde, $rcondv, $info); $eigens = PDL::Complex::complex t(cat $wr, $wi); } else{ $a->xchg(1,2)->cggevx($balanc, $jobvl, $jobvr, $sense, $b, $eigens, $beta, $vl, $vr, $ilo, $ihi, $lscale, $rscale, $abnrm, $bbnrm, $rconde, $rcondv, $info); } if ( ($info > 0) && ($info < $adims[-1])){ laerror("mgeigenx: The QZ algorithm failed to converge"); print ("Returning converged eigenvalues\n") if $_laerror; } elsif($info){ laerror("mgeigenx: Error from hgeqz or tgevc"); } $result{'aschur'} = $a if $opt{'schur'}; $result{'bschur'} = $b->xchg(-1,-2)->sever if $opt{'schur'}; if ($opt{'permute'}){ my $balance = cat $ilo, $ihi; $result{'balance'} = $balance; } $result{'info'} = $info; $result{'rscale'} = $rscale if $opt{'scale'}; $result{'lscale'} = $lscale if $opt{'scale'}; $result{'anorm'} = $abnrm; $result{'bnorm'} = $bbnrm; # Doesn't use lacpy2 =(sqrt **2 , **2) without unnecessary overflow if ( $opt{'rcondition'} eq 'vector' || $opt{'rcondition'} eq "all"){ $result{'rcondv'} = $rcondv; if ($opt{'error'}){ $abnrm = sqrt ($abnrm->pow(2) + $bbnrm->pow(2)); $result{'verror'} = (lamch(pdl($type,0))* $abnrm /$rcondv ); } } if ( $opt{'rcondition'} eq 'value' || $opt{'rcondition'} eq "all"){ $result{'rconde'} = $rconde; if ($opt{'error'}){ $abnrm = sqrt ($abnrm->pow(2) + $bbnrm->pow(2)); $result{'eerror'} = (lamch(pdl($type,0))* $abnrm /$rconde ); } } if ($opt{'vector'} eq 'left'){ return ($eigens, $beta, $vl->xchg(-1,-2)->sever, %result); } elsif ($opt{'vector'} eq 'right'){ return ($eigens, $beta, $vr->xchg(-1,-2)->sever, %result); } elsif ($opt{'vector'} eq 'all'){ return ($eigens, $beta, $vl->xchg(-1,-2)->sever, $vr->xchg(-1,-2)->sever, %result); } else{ return ($eigens, $beta, %result); } } =head2 msymeigen =for ref Computes eigenvalues and, optionally eigenvectors of a real symmetric square or complex Hermitian matrix (spectral decomposition). The eigenvalues are computed from lower or upper triangular matrix. If only eigenvalues are requested, info is returned in array context. Supports threading and works inplace if eigenvectors are requested. From Lapack, uses L or L for real and L or L for complex. Works on transposed array(s). =for usage (PDL(values), (PDL(VECTORS)), PDL(info)) = msymeigen(PDL, SCALAR(uplo), SCALAR(vector), SCALAR(method)) uplo : UPPER = 0 | LOWER = 1, default = 0 vector : FALSE = 0 | TRUE = 1, default = 0 method : 'syev' | 'syevd' | 'cheev' | 'cheevd', default = 'syevd'|'cheevd' =for example # Assume $a is symmetric my $a = random(10,10); my ( $eigenvalues, $eigenvectors ) = msymeigen($a,0,1, 'syev'); =cut sub msymeigen{ my $m = shift; $m->msymeigen(@_); } sub PDL::msymeigen { my($m, $upper, $jobv, $method) = @_; my(@dims) = $m->dims; barf("msymeigen: Require square array(s)") unless( @dims >= 2 && $dims[0] == $dims[1]); my ($w, $v, $info); $info = null; $w = null; $method = 'syevd' unless defined $method; $m = $m->copy unless ($m->is_inplace(0) and $jobv); $m->xchg(0,1)->$method($jobv, $upper, $w, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msymeigen: The algorithm failed to converge for PDL(s) @list: \$info = $info"); } $jobv ? wantarray ? ($w , $m, $info) : $w : wantarray ? ($w, $info) : $w; } sub PDL::Complex::msymeigen { my($m, $upper, $jobv, $method) = @_; my(@dims) = $m->dims; barf("msymeigen: Require square array(s)") unless( @dims >= 3 && $dims[1] == $dims[2]); my ($w, $v, $info); $info = null; $w = null; #PDL::new_from_specification('PDL', $m->type, $dims[1]); $m = $m->copy unless ($m->is_inplace(0) and $jobv); $method = 'cheevd' unless defined $method; $m->xchg(1,2)->$method($jobv, $upper, $w, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msymeigen: The algorithm failed to converge for PDL(s) @list: \$info = $info"); } $jobv ? wantarray ? ($w , $m, $info) : $w : wantarray ? ($w, $info) : $w; } =head2 msymeigenx =for ref Computes eigenvalues and, optionally eigenvectors of a symmetric square matrix (spectral decomposition). The eigenvalues are computed from lower or upper triangular matrix and can be selected by specifying a range. From Lapack, uses L or L for real and L or L for complex. Works on transposed arrays. =for usage (PDL(value), (PDL(vector)), PDL(n), PDL(info), (PDL(support)) ) = msymeigenx(PDL, SCALAR(uplo), SCALAR(vector), HASH(options)) uplo : UPPER = 0 | LOWER = 1, default = 0 vector : FALSE = 0 | TRUE = 1, default = 0 where options are: range_type: method for selecting eigenvalues indice: range of indices interval: range of values 0: find all eigenvalues and optionally all vectors range: PDL(2), lower and upper bounds interval or smallest and largest indices 1<=range<=N for indice abstol: specifie error tolerance for eigenvalues method: specifie which method to use (see Lapack for further details) 'syevx' (default) 'syevr' 'cheevx' (default) 'cheevr' Returned values: eigenvalues (SCALAR CONTEXT), eigenvectors if requested, total number of eigenvalues found (n), info issupz or ifail (support) according to method used and returned info, for (sy|che)evx returns support only if info != 0 =for example # Assume $a is symmetric my $a = random(10,10); my $overflow = lamch(9); my $range = cat pdl(0),$overflow; my $abstol = pdl(1.e-5); my %options = (range_type=>'interval', range => $range, abstol => $abstol, method=>'syevd'); my ( $eigenvalues, $eigenvectors, $n, $isuppz ) = msymeigenx($a,0,1, %options); =cut *msymeigenx = \&PDL::msymeigenx; sub PDL::msymeigenx { my($m, $upper, $jobv, %opt) = @_; my(@dims) = $m->dims; barf("msymeigenx: Require a square matrix") unless( ( (@dims == 2)|| (@dims == 3) )&& $dims[-1] == $dims[-2]); my ($w, $v, $info, $n, $support, $z, $range, $method, $type); $type = $m->type; $range = ($opt{'range_type'} eq 'interval') ? pdl(long, 1) : ($opt{'range_type'} eq 'indice')? pdl(long, 2) : pdl(long, 0); if ((ref $opt{range}) ne 'PDL'){ $opt{range} = pdl($type,[0,0]); $range = pdl(long, 0); } elsif ($range == 2){ barf "msymeigenx: Indices must be > 0" unless $opt{range}->(0) > 0; barf "msymeigenx: Indices must be <= $dims[1]" unless $opt{range}->(1) <= $dims[1]; } elsif ($range == 1){ barf "msymeigenx: Interval limits must be differents" unless ($opt{range}->(0) != $opt{range}->(1)); } $w = PDL::new_from_specification('PDL', $type, $dims[1]); $n = null; $info = pdl(long,0); if (!defined $opt{'abstol'}) { my ( $unfl, $ovfl ); $unfl = lamch(pdl($type,1)); $ovfl = lamch(pdl($type,9)); $unfl->labad($ovfl); $opt{'abstol'} = $unfl + $unfl; } $method = $opt{'method'} ? $opt{'method'} : (@dims == 3) ? 'PDL::LinearAlgebra::Complex::cheevx' : 'PDL::LinearAlgebra::Real::syevx'; if ( $method =~ 'evx' && $jobv){ $support = zeroes(long, $dims[1]); } elsif ($method =~ 'evr' && $jobv){ $support = zeroes(long, (2*$dims[1])); } if (@dims == 3){ $upper = $upper ? pdl(long,1) : pdl(long,0); $m = $m->xchg(1,2)->copy; $z = $jobv ? PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]) : pdl($type,[0,0]); $m->$method($jobv, $range, $upper, $opt{range}->(0), $opt{range}->(1),$opt{range}->(0),$opt{range}->(1), $opt{'abstol'}, $n, $w, $z , $support, $info); } else{ $upper = $upper ? pdl(long,0) : pdl(long,1); $m = $m->copy; $z = $jobv ? PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) : pdl($type,0); $m->$method($jobv, $range, $upper, $opt{range}->(0), $opt{range}->(1),$opt{range}->(0),$opt{range}->(1), $opt{'abstol'}, $n, $w, $z ,$support, $info); } if ($info){ laerror("msymeigenx: The algorithm failed to converge."); print ("See support for details.\n") if $_laerror; } if ($jobv){ if ($info){ return ($w , $z->xchg(-2,-1)->sever, $n, $info, $support); } elsif ($method =~ 'evr'){ return (undef,undef,$n,$info,$support) if $n == 0; return (@dims == 3) ? ($w(:$n-1)->sever , $z->xchg(1,2)->(,:$n-1,)->sever, $n, $info, $support) : ($w(:$n-1)->sever , $z->xchg(0,1)->(:$n-1,)->sever, $n, $info, $support); } else{ return (undef,undef,$n, $info) if $n == 0; return (@dims == 3) ? ($w(:$n-1)->sever , $z->xchg(1,2)->(,:$n-1,)->sever, $n, $info) : ($w(:$n-1)->sever , $z->xchg(0,1)->(:$n-1,)->sever, $n, $info); } } else{ if ($info){ wantarray ? ($w, $n, $info, $support) : $w; } elsif ($method =~ 'evr'){ wantarray ? ($w(:$n-1)->sever, $n, $info, $support) : $w; } else{ wantarray ? ($w(:$n-1)->sever, $n, $info) : $w; } } } =head2 msymgeigen =for ref Computes eigenvalues and, optionally eigenvectors of a real generalized symmetric-definite or Hermitian-definite eigenproblem. The eigenvalues are computed from lower or upper triangular matrix If only eigenvalues are requested, info is returned in array context. Supports threading. From Lapack, uses L or L for real or L or L for complex. Works on transposed array(s). =for usage (PDL(values), (PDL(vectors)), PDL(info)) = msymgeigen(PDL(a), PDL(b),SCALAR(uplo), SCALAR(vector), SCALAR(type), SCALAR(method)) uplo : UPPER = 0 | LOWER = 1, default = 0 vector : FALSE = 0 | TRUE = 1, default = 0 type : 1: A * x = (lambda) * B * x 2: A * B * x = (lambda) * x 3: B * A * x = (lambda) * x default = 1 method : 'sygv' | 'sygvd' for real or ,'chegv' | 'chegvd' for complex, default = 'sygvd' | 'chegvd' =for example # Assume $a is symmetric my $a = random(10,10); my $b = random(10,10); $b = $b->crossprod($b); my ( $eigenvalues, $eigenvectors ) = msymgeigen($a, $b, 0, 1, 1, 'sygv'); =cut sub msymgeigen{ my $a = shift; $a->msymgeigen(@_); } sub PDL::msymgeigen { my($a, $b, $upper, $jobv, $type, $method) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; barf("msymgeigen: Require square matrices of same order") unless( @adims >= 2 && @bdims >= 2 && $adims[0] == $adims[1] && $bdims[0] == $bdims[1] && $adims[0] == $bdims[0]); barf("msymgeigen: Require matrices with equal number of dimensions") if( @adims != @bdims); $type = 1 unless $type; my ($w, $v, $info); $method = 'PDL::LinearAlgebra::Real::sygvd' unless defined $method; $upper = 1-$upper; $a = $a->copy; $b = $b->copy; $w = null; $info = null; $a->$method($type, $jobv, $upper, $b, $w, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msymgeigen: Can't compute eigenvalues/vectors: matrix (PDL(s) @list) is/are not positive definite(s) or the algorithm failed to converge: \$info = $info"); } return $jobv ? ($w , $a->xchg(0,1)->sever, $info) : wantarray ? ($w, $info) : $w; } sub PDL::Complex::msymgeigen { my($a, $b, $upper, $jobv, $type, $method) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; barf("msymgeigen: Require 2 square matrices of same order") unless( @adims >= 3 && @bdims >= 3 && $adims[1] == $adims[2] && $bdims[1] == $bdims[2] && $adims[1] == $bdims[1]); barf("msymgeigen: Require matrices with equal number of dimensions") if( @adims != @bdims); $type = 1 unless $type; my ($w, $v, $info); $method = 'PDL::LinearAlgebra::Complex::chegvd' unless defined $method; $a = $a->xchg(1,2)->copy; $b = $b->xchg(1,2)->copy; $w = null; $info = null; # TODO bug in chegv ??? $a->$method($type, $jobv, $upper, $b, $w, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msymgeigen: Can't compute eigenvalues/vectors: matrix (PDL(s) @list) is/are not positive definite(s) or the algorithm failed to converge: \$info = $info"); } return $jobv ? ($w , $a->xchg(1,2)->sever, $info) : wantarray ? ($w, $info) : $w; } =head2 msymgeigenx =for ref Computes eigenvalues and, optionally eigenvectors of a real generalized symmetric-definite or Hermitian eigenproblem. The eigenvalues are computed from lower or upper triangular matrix and can be selected by specifying a range. Uses L or L from Lapack. Works on transposed arrays. =for usage (PDL(value), (PDL(vector)), PDL(info), PDL(n), (PDL(support)) ) = msymeigenx(PDL(a), PDL(b), SCALAR(uplo), SCALAR(vector), HASH(options)) uplo : UPPER = 0 | LOWER = 1, default = 0 vector : FALSE = 0 | TRUE = 1, default = 0 where options are: type : Specifies the problem type to be solved 1: A * x = (lambda) * B * x 2: A * B * x = (lambda) * x 3: B * A * x = (lambda) * x default = 1 range_type: method for selecting eigenvalues indice: range of indices interval: range of values 0: find all eigenvalues and optionally all vectors range: PDL(2), lower and upper bounds interval or smallest and largest indices 1<=range<=N for indice abstol: specifie error tolerance for eigenvalues Returned values: eigenvalues (SCALAR CONTEXT), eigenvectors if requested, total number of eigenvalues found (n), info ifail according to returned info (support). =for example # Assume $a is symmetric my $a = random(10,10); my $b = random(10,10); $b = $b->crossprod($b); my $overflow = lamch(9); my $range = cat pdl(0),$overflow; my $abstol = pdl(1.e-5); my %options = (range_type=>'interval', range => $range, abstol => $abstol, type => 1); my ( $eigenvalues, $eigenvectors, $n, $isuppz ) = msymgeigenx($a, $b, 0,1, %options); =cut *msymgeigenx = \&PDL::msymgeigenx; sub PDL::msymgeigenx { my($a, $b, $upper, $jobv, %opt) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; if(@adims == 3){ barf("msymgeigenx: Require 2 square matrices of same order") unless( @bdims == 3 && $adims[1] == $adims[2] && $bdims[1] == $bdims[2] && $adims[1] == $bdims[1]); } else{ barf("msymgeigenx: Require 2 square matrices of same order") unless( @adims == 2 && @bdims == 2 && $adims[0] == $adims[1] && $bdims[0] == $bdims[1] && $adims[0] == $bdims[0]); } my ($w, $info, $n, $support, $z, $range, $type); $type = $a->type; $range = ($opt{'range_type'} eq 'interval') ? pdl(long, 1) : ($opt{'range_type'} eq 'indice')? pdl(long, 2) : pdl(long, 0); if (UNIVERSAL::isa($opt{range},'PDL')){ $opt{range} = pdl($type,[0,0]); $range = pdl(long, 0); } $opt{type} = 1 unless (defined $opt{type}); $w = PDL::new_from_specification('PDL', $type, $adims[1]); $n = pdl(long,0); $info = pdl(long,0); if (!defined $opt{'abstol'}){ my ( $unfl, $ovfl ); $unfl = lamch(pdl($type,1)); $ovfl = lamch(pdl($type,9)); $unfl->labad($ovfl); $opt{'abstol'} = $unfl + $unfl; } $support = zeroes(long, $adims[1]) if $jobv; $w = PDL::new_from_specification('PDL', $type, $adims[1]); $z = PDL::zeroes $a; if (@adims ==3){ $upper = $upper ? pdl(long,1) : pdl(long,0); $a = $a->xchg(-1,-2)->copy; $b = $b->xchg(-1,-2)->copy; $a->chegvx($opt{type}, $jobv, $range, $upper, $b, $opt{range}->(0), $opt{range}->(1),$opt{range}->(0),$opt{range}->(1), $opt{'abstol'}, $n, $w, $z ,$support, $info); } else{ $upper = $upper ? pdl(long,0) : pdl(long,1); $a = $a->copy; $b = $b->copy; $a->sygvx($opt{type}, $jobv, $range, $upper, $b, $opt{range}->(0), $opt{range}->(1),$opt{range}->(0),$opt{range}->(1), $opt{'abstol'}, $n, $w, $z ,$support, $info); } if ( ($info > 0) && ($info < $adims[-1])){ laerror("msymgeigenx: The algorithm failed to converge"); print("see support for details\n") if $_laerror; } elsif($info){ $info = $info - $adims[-1] - 1; barf("msymgeigenx: The leading minor of order $info of B is not positive definite\n"); } if ($jobv){ if ($info){ return ($w , $z->xchg(-1,-2)->sever, $n, $info, $support) ; } else{ return ($w , $z->xchg(-1,-2)->sever, $n, $info); } } else{ if ($info){ wantarray ? ($w, $n, $info, $support) : $w; } else{ wantarray ? ($w, $n, $info) : $w; } } } =head2 mdsvd =for ref Computes SVD using Coppen's divide and conquer algorithm. Return singular values in scalar context else left (U), singular values, right (V' (hermitian for complex)) singular vectors and info. Supports threading. If only singulars values are requested, info is only returned in array context. Uses L or L from Lapack. =for usage (PDL(U), (PDL(s), PDL(V)), PDL(info)) = mdsvd(PDL, SCALAR(job)) job : 0 = computes only singular values 1 = computes full SVD (square U and V) 2 = computes SVD (singular values, right and left singular vectors) default = 1 =for example my $a = random(5,10); my ($u, $s, $v) = mdsvd($a); =cut sub mdsvd{ my $a = shift; $a->mdsvd(@_); } sub PDL::mdsvd { my($m, $job) = @_; my(@dims) = $m->dims; my ($u, $s, $v, $min, $info, $type); $type = $m->type; if (wantarray){ $job = 1 unless defined($job); } else{ $job = 0; } $min = $dims[0] > $dims[1] ? $dims[1]: $dims[0]; $info = null; $s = null; $m = $m->copy; if ($job){ if ($job == 2){ $u = PDL::new_from_specification('PDL', $type, $min, $dims[1],@dims[2..$#dims]); $v = PDL::new_from_specification('PDL', $type, $dims[0],$min,@dims[2..$#dims]); } else{ $u = PDL::new_from_specification('PDL', $type, $dims[1],$dims[1],@dims[2..$#dims]); $v = PDL::new_from_specification('PDL', $type, $dims[0],$dims[0],@dims[2..$#dims]); } }else{ $u = PDL::new_from_specification('PDL', $type, 1,1); $v = PDL::new_from_specification('PDL', $type, 1,1); } $m->gesdd($job, $s, $v, $u, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mdsvd: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } if ($job){ return ($u, $s, $v, $info); }else{ return wantarray ? ($s, $info) : $s; } } #Humm... $a= cplx random(2,4,5) sub PDL::Complex::mdsvd { my($m, $job) = @_; my(@dims) = $m->dims; my ($u, $s, $v, $min, $info, $type); $type = $m->type; if (wantarray){ $job = 1 unless defined($job); } else{ $job = 0; } $min = $dims[-2] > $dims[-1] ? $dims[-1]: $dims[-2]; $info=null; $s = null; $m = $m->copy; if ($job){ if ($job == 2){ $u = PDL::new_from_specification('PDL::Complex', $type, 2,$min, $dims[2],@dims[3..$#dims]); $v = PDL::new_from_specification('PDL::Complex', $type, 2,$dims[1],$min,@dims[3..$#dims]); } else{ $u = PDL::new_from_specification('PDL::Complex', $type, 2,$dims[2],$dims[2],@dims[3..$#dims]); $v = PDL::new_from_specification('PDL::Complex', $type, 2,$dims[1],$dims[1],@dims[3..$#dims]); } }else{ $u = PDL::new_from_specification('PDL', $type, 2,1,1); $v = PDL::new_from_specification('PDL', $type, 2,1,1); } $m->cgesdd($job, $s, $v, $u, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("mdsvd: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } if ($job){ return ($u, $s, $v, $info); }else{ return wantarray ? ($s, $info) : $s; } } =head2 msvd =for ref Computes SVD. Can compute singular values, either U or V or neither. Return singulars values in scalar context else left (U), singular values, right (V' (hermitian for complex) singulars vector and info. Supports threading. If only singulars values are requested, info is returned in array context. Uses L or L from Lapack. =for usage ( (PDL(U)), PDL(s), (PDL(V), PDL(info)) = msvd(PDL, SCALAR(jobu), SCALAR(jobv)) jobu : 0 = Doesn't compute U 1 = computes full SVD (square U) 2 = computes right singular vectors default = 1 jobv : 0 = Doesn't compute V 1 = computes full SVD (square V) 2 = computes left singular vectors default = 1 =for example my $a = random(10,10); my ($u, $s, $v) = msvd($a); =cut sub msvd{ my $a = shift; $a->msvd(@_); } sub PDL::msvd { my($m, $jobu, $jobv) = @_; my(@dims) = $m->dims; my ($u, $s, $v, $min, $info, $type); $type = $m->type; if (wantarray){ $jobu = 1 unless defined $jobu; $jobv = 1 unless defined $jobv; } else{ $jobu = 0; $jobv = 0; } $m = $m->copy; $min = $dims[-2] > $dims[-1] ? $dims[-1]: $dims[-2]; $s = null; $info = null; if ($jobv){ $v = ($jobv == 1) ? PDL::new_from_specification('PDL', $type, $dims[0],$dims[0],@dims[2..$#dims]): PDL::new_from_specification('PDL', $type, $dims[0],$min,@dims[2..$#dims]); }else {$v = PDL::new_from_specification('PDL', $type, 1,1);} if ($jobu){ $u = ($jobu == 1) ? PDL::new_from_specification('PDL', $type, $dims[1],$dims[1],@dims[2..$#dims]): PDL::new_from_specification('PDL', $type, $min, $dims[1],@dims[2..$#dims]); }else {$u = PDL::new_from_specification('PDL', $type, 1,1);} $m->gesvd($jobv, $jobu,$s, $v, $u, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msvd: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } if ($jobu){ if ($jobv){ return ($u, $s, $v, $info); } return ($u, $s, $info); } elsif($jobv){ return ($s, $v, $info); } else{return wantarray ? ($s, $info) : $s;} } sub PDL::Complex::msvd{ my($m, $jobu, $jobv) = @_; my(@dims) = $m->dims; my ($u, $s, $v, $min, $info, $type); $type = $m->type; if (wantarray){ $jobu = 1 unless defined $jobu; $jobv = 1 unless defined $jobv; } else{ $jobu = 0; $jobv = 0; } $m = $m->copy; $min = $dims[-2] > $dims[-1] ? $dims[-1]: $dims[-2]; $s = null; $info = null; if ($jobv){ $v = ($jobv == 1) ? PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1],$dims[1],@dims[3..$#dims]): PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1],$min,@dims[3..$#dims]); }else {$v = PDL::new_from_specification('PDL', $type, 2,1,1);} if ($jobu){ $u = ($jobu == 1) ? PDL::new_from_specification('PDL::Complex', $type, 2, $dims[2],$dims[2],@dims[3..$#dims]): PDL::new_from_specification('PDL::Complex', $type, 2, $min, $dims[2],@dims[3..$#dims]); }else {$u = PDL::new_from_specification('PDL', $type, 2,1,1);} $m->cgesvd($jobv, $jobu,$s, $v, $u, $info); if($info->max > 0 && $_laerror) { my ($index,@list); $index = which($info > 0)+1; @list = $index->list; laerror("msvd: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); } if ($jobu){ if ($jobv){ return ($u, $s, $v, $info); } return ($u, $s, $info); } elsif($jobv){ return ($s, $v, $info); } else{return wantarray ? ($s, $info) : $s;} } =head2 mgsvd =for ref Computes generalized (or quotient) singular value decomposition. If the effective rank of (A',B')' is 0 return only unitary V, U, Q. For complex number, needs object of type PDL::Complex. Uses L or L from Lapack. Works on transposed arrays. =for usage (PDL(sa), PDL(sb), %ret) = mgsvd(PDL(a), PDL(b), %HASH(options)) where options are: V: whether or not computes V (boolean, returned in HASH{'V'}) U: whether or not computes U (boolean, returned in HASH{'U'}) Q: whether or not computes Q (boolean, returned in HASH{'Q'}) D1: whether or not computes D1 (boolean, returned in HASH{'D1'}) D2: whether or not computes D2 (boolean, returned in HASH{'D2'}) 0R: whether or not computes 0R (boolean, returned in HASH{'0R'}) R: whether or not computes R (boolean, returned in HASH{'R'}) X: whether or not computes X (boolean, returned in HASH{'X'}) all: whether or not computes all the above. Returned value: sa,sb : singular value pairs of A and B (generalized singular values = sa/sb) $ret{'rank'} : effective numerical rank of (A',B')' $ret{'info'} : info from (c)ggsvd =for example my $a = random(5,5); my $b = random(5,7); my ($c, $s, %ret) = mgsvd($a, $b, X => 1); =cut sub mgsvd{ my $m =shift; $m->mgsvd(@_); } sub PDL::mgsvd { my($a, $b, %opt) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; barf("mgsvd: Require matrices with equal number of columns") unless( @adims == 2 && @bdims == 2 && $adims[0] == $bdims[0] ); my ($U, $V, $Q, $alpha, $beta, $k, $l, $iwork, $info, $D2, $D1, $work, %ret, $X, $jobqx, $type); if ($opt{all}){ $opt{'V'} = 1; $opt{'U'} = 1; $opt{'Q'} = 1; $opt{'D1'} = 1; $opt{'D2'} = 1; $opt{'0R'} = 1; $opt{'R'} = 1; $opt{'X'} = 1; } $type = $a->type; $jobqx = ($opt{Q} || $opt{X}) ? 1 : 0; $a = $a->copy; $b = $b->xchg(0,1)->copy; $k = null; $l = null; $alpha = zeroes($type, $adims[0]); $beta = zeroes($type, $adims[0]); $U = $opt{U} ? zeroes($type, $adims[1], $adims[1]) : zeroes($type,1,1); $V = $opt{V} ? zeroes($b->type, $bdims[1], $bdims[1]) : zeroes($b->type,1,1); $Q = $jobqx ? zeroes($type, $adims[0], $adims[0]) : zeroes($type,1,1); $iwork = zeroes(long, $adims[0]); $info = pdl(long, 0); $a->xchg(0,1)->ggsvd($opt{U}, $opt{V}, $jobqx, $b, $k, $l, $alpha, $beta, $U, $V, $Q, $iwork, $info); laerror("mgsvd: The Jacobi procedure fails to converge") if $info; $ret{rank} = $k + $l; warn "mgsvd: Effective rank of 0 in mgsvd" if (!$ret{rank} and $_laerror); $ret{'info'} = $info; if (%opt){ $Q = $Q->xchg(0,1)->sever if $jobqx; if (($adims[1] - $k - $l) < 0 && $ret{rank}){ if ( $opt{'0R'} || $opt{R} || $opt{X}){ $a->reshape($adims[0], ($k + $l)); # Slice $a ??? => always square ?? $a ( ($adims[0] - (($k+$l) - $adims[1])) : , $adims[1]:) .= $b(($adims[1]-$k):($l-1),($adims[0]+$adims[1]-$k - $l):($adims[0]-1))->xchg(0,1); $ret{'0R'} = $a if $opt{'0R'}; } if ($opt{'D1'}){ $D1 = zeroes($type, $adims[1], $adims[1]); $D1->diagonal(0,1) .= $alpha(:($adims[1]-1)); $D1 = $D1->xchg(0,1)->reshape($adims[1] , ($k+$l))->xchg(0,1)->sever; $ret{'D1'} = $D1; } } elsif ($ret{rank}){ if ( $opt{'0R'} || $opt{R} || $opt{X}){ $a->reshape($adims[0], ($k + $l)); $ret{'0R'} = $a if $opt{'0R'}; } if ($opt{'D1'}){ $D1 = zeroes($type, ($k + $l), ($k + $l)); $D1->diagonal(0,1) .= $alpha(:($k+$l-1)); $D1->reshape(($k + $l), $adims[1]); $ret{'D1'} = $D1; } } if ($opt{'D2'} && $ret{rank}){ $work = zeroes($b->type, $l, $l); $work->diagonal(0,1) .= $beta($k:($k+$l-1)); $D2 = zeroes($b->type, ($k + $l), $bdims[1]); $D2( $k:, :($l-1) ) .= $work; $ret{'D2'} = $D2; } if ( $ret{rank} && ($opt{X} || $opt{R}) ){ $work = $a( -($k + $l):,); $ret{R} = $work if $opt{R}; if ($opt{X}){ $X = zeroes($type, $adims[0], $adims[0]); $X->diagonal(0,1) .= 1 if ($adims[0] > ($k + $l)); $X ( -($k + $l): , -($k + $l): ) .= mtriinv($work); $ret{X} = $Q x $X; } } $ret{U} = $U->xchg(0,1)->sever if $opt{U}; $ret{V} = $V->xchg(0,1)->sever if $opt{V}; $ret{Q} = $Q if $opt{Q}; } $ret{rank} ? return ($alpha($k:($k+$l-1))->sever, $beta($k:($k+$l-1))->sever, %ret ) : (undef, undef, %ret); } sub PDL::Complex::mgsvd { my($a, $b, %opt) = @_; my(@adims) = $a->dims; my(@bdims) = $b->dims; barf("mgsvd: Require matrices with equal number of columns") unless( @adims == 3 && @bdims == 3 && $adims[1] == $bdims[1] ); my ($U, $V, $Q, $alpha, $beta, $k, $l, $iwork, $info, $D2, $D1, $work, %ret, $X, $jobqx, $type); if ($opt{all}){ $opt{'V'} = 1; $opt{'U'} = 1; $opt{'Q'} = 1; $opt{'D1'} = 1; $opt{'D2'} = 1; $opt{'0R'} = 1; $opt{'R'} = 1; $opt{'X'} = 1; } $type = $a->type; $jobqx = ($opt{Q} || $opt{X}) ? 1 : 0; $a = $a->copy; $b = $b->xchg(1,2)->copy; $k = null; $l = null; $alpha = zeroes($type, $adims[1]); $beta = zeroes($type, $adims[1]); $U = $opt{U} ? PDL::new_from_specification('PDL::Complex', $type, 2,$adims[2], $adims[2]) : zeroes($type,1,1); $V = $opt{V} ? PDL::new_from_specification('PDL::Complex', $b->type, 2,$bdims[2], $bdims[2]) : zeroes($b->type,1,1); $Q = $jobqx ? PDL::new_from_specification('PDL::Complex', $type, 2,$adims[1], $adims[1]) : zeroes($type,1,1); $iwork = zeroes(long, $adims[1]); $info = null; $a->xchg(1,2)->cggsvd($opt{U}, $opt{V}, $jobqx, $b, $k, $l, $alpha, $beta, $U, $V, $Q, $iwork, $info); $k = $k->sclr; $l = $l->sclr; laerror("mgsvd: The Jacobi procedure fails to converge") if $info; $ret{rank} = $k + $l; warn "mgsvd: Effective rank of 0 in mgsvd" if (!$ret{rank} and $_laerror); $ret{'info'} = $info; if (%opt){ $Q = $Q->xchg(1,2)->sever if $jobqx; if (($adims[2] - $k - $l) < 0 && $ret{rank}){ if ( $opt{'0R'} || $opt{R} || $opt{X}){ $a->reshape(2,$adims[1], ($k + $l)); # Slice $a ??? => always square ?? $a (, ($adims[1] - (($k+$l) - $adims[2])) : , $adims[2]:) .= $b(,($adims[2]-$k):($l-1),($adims[1]+$adims[2]-$k - $l):($adims[1]-1))->xchg(1,2); $ret{'0R'} = $a if $opt{'0R'}; } if ($opt{'D1'}){ $D1 = zeroes($type, $adims[2], $adims[2]); $D1->diagonal(0,1) .= $alpha(:($adims[2]-1)); $D1 = $D1->xchg(0,1)->reshape($adims[2] , ($k+$l))->xchg(0,1)->sever; $ret{'D1'} = $D1; } } elsif ($ret{rank}){ if ( $opt{'0R'} || $opt{R} || $opt{X}){ $a->reshape(2, $adims[1], ($k + $l)); $ret{'0R'} = $a if $opt{'0R'}; } if ($opt{'D1'}){ $D1 = zeroes($type, ($k + $l), ($k + $l)); $D1->diagonal(0,1) .= $alpha(:($k+$l-1)); $D1->reshape(($k + $l), $adims[2]); $ret{'D1'} = $D1; } } if ($opt{'D2'} && $ret{rank}){ $work = zeroes($b->type, $l, $l); $work->diagonal(0,1) .= $beta($k:($k+$l-1)); $D2 = zeroes($b->type, ($k + $l), $bdims[2]); $D2( $k:, :($l-1) ) .= $work; $ret{'D2'} = $D2; } if ( $ret{rank} && ($opt{X} || $opt{R}) ){ $work = $a( , -($k + $l):,); $ret{R} = $work if $opt{R}; if ($opt{X}){ # $X = #zeroes($type, 2, $adims[1], $adims[1]); $X = PDL::new_from_specification('PDL::Complex', $type, 2, $adims[1], $adims[1]); $X .= 0; $X->diagonal(1,2)->(0,) .= 1 if ($adims[1] > ($k + $l)); $X ( ,-($k + $l): , -($k + $l): ) .= mtriinv($work); $ret{X} = $Q x $X; } } $ret{U} = $U->xchg(1,2)->sever if $opt{U}; $ret{V} = $V->xchg(1,2)->sever if $opt{V}; $ret{Q} = $Q if $opt{Q}; } $ret{rank} ? return ($alpha($k:($k+$l-1))->sever, $beta($k:($k+$l-1))->sever, %ret ) : (undef, undef, %ret); } #TODO # Others things # rectangular diag # usage # is_inplace and function which modify entry matrix # avoid xchg # threading support # automatically create PDL # inplace operation and memory #d check s after he/she/it and matrix(s) # PDL type, verify float/double # eig_det qr_det # (g)schur(x): # if conjugate pair # non generalized pb: $seldim ?? (cf: generalized) # return conjugate pair if only selected? # port to PDL::Matrix =head1 AUTHOR Copyright (C) Grégory Vanuxem 2005-2007. This library is free software; you can redistribute it and/or modify it under the terms of the artistic license as specified in the Artistic file. =cut 1; PDL-LinearAlgebra-0.12/Makefile.PL0000755113142400244210000000210312535324310020726 0ustar chris.h.marshallDomain Usersuse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::LinearAlgebra', 'ABSTRACT' => 'PDL bindings to some BLAS and LAPACK library routines', 'AUTHOR' => [ 'Chris Marshall ' ], 'VERSION_FROM' => 'LinearAlgebra.pm', 'LICENSE' => 'artistic_2', 'META_MERGE' => { "meta-spec" => { version => 2 }, resources => { homepage => 'http://pdl.perl.org/', repository => { url => 'git://git.code.sf.net/p/pdl/pdl-linearalgebra', type => 'git', web => 'http://sourceforge.net/p/pdl/pdl-linearalgebra/ci/master/tree/', }, }, }, 'CONFIGURE_REQUIRES' => { "PDL" => 0, }, 'BUILD_REQUIRES' => { "PDL" => 0, }, 'PREREQ_PM' => { "PDL" => 0, "constant" => 1.03, }, 'DIR' => [ qw/Trans Real Complex Special/], 'dist' => { PREOP=>'$(PERL) -MPDL::Core::Dev -e pdlpp_mkgen $(DISTVNAME)' }, # GENERATED subdir in dist tarball 'clean' => { FILES => '*~' }, ); __END__ PDL-LinearAlgebra-0.12/MANIFEST0000644113142400244210000000145512535325336020124 0ustar chris.h.marshallDomain UsersArtistic_2 Changes Complex/complex.pd Complex/Makefile.PL Complex/Makefile.PL.pkg Config LinearAlgebra.pm Makefile.PL MANIFEST This list of files README Real/Makefile.PL Real/Makefile.PL.pkg Real/real.pd Special/Makefile.PL Special/Special.pm t/1.t Trans/Makefile.PL Trans/Makefile.PL.pkg Trans/trans.pd META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) GENERATED/PDL/LinearAlgebra/Complex.pm mod=PDL::LinearAlgebra::Complex pd=Complex/complex.pd (added by pdlpp_mkgen) GENERATED/PDL/LinearAlgebra/Real.pm mod=PDL::LinearAlgebra::Real pd=Real/real.pd (added by pdlpp_mkgen) GENERATED/PDL/LinearAlgebra/Trans.pm mod=PDL::LinearAlgebra::Trans pd=Trans/trans.pd (added by pdlpp_mkgen) PDL-LinearAlgebra-0.12/META.json0000644113142400244210000000222512535325333020405 0ustar chris.h.marshallDomain Users{ "abstract" : "PDL bindings to some BLAS and LAPACK library routines", "author" : [ "Chris Marshall " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.86, CPAN::Meta::Converter version 2.142060", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "PDL-LinearAlgebra", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "PDL" : "0" } }, "configure" : { "requires" : { "PDL" : "0" } }, "runtime" : { "requires" : { "PDL" : "0", "constant" : "1.03" } } }, "release_status" : "stable", "resources" : { "homepage" : "http://pdl.perl.org/", "repository" : { "type" : "git", "url" : "git://git.code.sf.net/p/pdl/pdl-linearalgebra", "web" : "http://sourceforge.net/p/pdl/pdl-linearalgebra/ci/master/tree/" } }, "version" : "0.12" } PDL-LinearAlgebra-0.12/META.yml0000644113142400244210000000114712535325331020235 0ustar chris.h.marshallDomain Users--- abstract: 'PDL bindings to some BLAS and LAPACK library routines' author: - 'Chris Marshall ' build_requires: PDL: '0' configure_requires: PDL: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.86, CPAN::Meta::Converter version 2.142060' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: PDL-LinearAlgebra no_index: directory: - t - inc requires: PDL: '0' constant: '1.03' resources: homepage: http://pdl.perl.org/ repository: git://git.code.sf.net/p/pdl/pdl-linearalgebra version: '0.12' PDL-LinearAlgebra-0.12/README0000644113142400244210000000167212444066235017653 0ustar chris.h.marshallDomain UsersPDL/LinearAlgebra version 0.08_01 ================================= This module provides a PDL interface to some routines of BLAS and LAPACK library. Moreover it provides some linear algebra based routines (transcendental functions for matrices) and some easy constructors for well known matrices. BLAS and LAPACK libraries can be retrieved for example at www.netlib.org. INSTALLATION To install this module edit Real/Makefile.PL, Complex/Makefile.PL and Trans/Makefile.PL to reflect your local BLAS and LAPACK installation and type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires PDL and working BLAS and LAPACK libraries. COPYRIGHT AND LICENCE Copyright (C) 2005-2007 Grégory Vanuxem Copyright (C) 2013 Chris Marshall This library is free software; you can redistribute it and/or modify it under the terms of the Perl Artistic License as in the file Artistic_2 in this distribution. PDL-LinearAlgebra-0.12/Real/0000755113142400244210000000000012535325330017643 5ustar chris.h.marshallDomain UsersPDL-LinearAlgebra-0.12/Real/Makefile.PL0000755113142400244210000000316012535324536021627 0ustar chris.h.marshallDomain Users # Use this as a template for the Makefile.PL for # any external PDL module. use ExtUtils::MakeMaker; use PDL::Core::Dev; use Config; do('../Config'); @pack = (["real.pd",Real,PDL::LinearAlgebra::Real]); %hash = pdlpp_stdargs(@::pack); #$hash{LIBS}[0] .= $^O =~ /MSWin/ ? '' : '-lacml -lgfortran '; #$hash{LIBS}[0] .= $^O =~ /MSWin/ ? '' : '-L/usr/lib/atlas -llapack -lblas -latlas '; # $hash{'OPTIMIZE'} = '-g'; # If you want to debug, uncomment this. #$hash{LIBS}[0] .= $^O =~ /MSWin/ ? '' : '-lacml -lgfortran '; #$hash{LIBS}[0] .= $^O =~ /MSWin/ ? '' : '-L/usr/lib/atlas -llapack -lblas -latlas '; #$hash{'OPTIMIZE'} = '-O2 -mtune=k8'; # If you want to debug, uncomment this. $hash{LIBS}[0] .= ( eval {require PkgConfig; join ' ', PkgConfig->find('lapack')->get_ldflags} || eval {require ExtUtils::PkgConfig; ExtUtils::PkgConfig->libs('lapack')} || `pkg-config lapack blas --libs` || '-L/usr/lib/atlas -llapack -lblas -latlas' ) . " -lgfortran -lquadmath"; $hash{LDLOADLIBS} .= 'oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib msvcrt.lib ../lapack/libacml.lib "C:\Program Files\Microsoft Visual Studio .NET 2003\Vc7\lib\msvcrt.lib" ' if $^O =~ /MSWin/ && $Config{cc} eq 'cl'; WriteMakefile( %hash, 'VERSION_FROM' => 'real.pd', 'clean' => { FILES => '*~' }, ); # Add genpp rule # add other makefile additions as required (see also ExtUtils::MakeMaker) sub MY::postamble { pdlpp_postamble(@::pack); } PDL-LinearAlgebra-0.12/Real/Makefile.PL.pkg0000755113142400244210000000160212247720255022404 0ustar chris.h.marshallDomain Users # Use this as a template for the Makefile.PL for # any external PDL module. use ExtUtils::MakeMaker; PDL::Core::Dev->import(); do('../Config'); @pack = (["Real.pd",Real,PDL::LinearAlgebra::Real]); %hash = pdlpp_stdargs_int(@::pack); # $hash{'OPTIMIZE'} = '-g'; # If you want to debug, uncomment this. $hash{LIBS}[0] .= $^O =~ /MSWin/ ? '' : '-L/usr/lib/atlas -llapack -lf77blas -lcblas -latlas -lg2c '; $hash{LDLOADLIBS} .= 'oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib msvcrt.lib ../lapack/lapack.lib' if $^O =~ /MSWin/; WriteMakefile( %hash, 'VERSION_FROM' => "real.pd", ); # Add genpp rule # add other makefile additions as required (see also ExtUtils::MakeMaker) sub MY::postamble { pdlpp_postamble_int(@::pack); } PDL-LinearAlgebra-0.12/Real/real.pd0000644113142400244210000126101512535324050021117 0ustar chris.h.marshallDomain Users# TODO 'further details' ======= ========= # If array not referenced, min 1. do('../Config'); our $VERSION = '0.12'; pp_setversion(qq{'$VERSION'}); $VERSION = eval $VERSION; use PDL::Exporter; #TODO # dot sub generate_code($){ if ($config{WITHOUT_THREAD}){ return ' #if 0 threadloop%{ %} #endif'.$_[0]; } else{ return $_[0]; } } if ($config{CBLAS}){ pp_addhdr('#include '); } if ($^O =~ /MSWin/) { pp_addhdr(' #include '); } pp_addhdr(' #include #if defined(PDL_CORE_VERSION) && PDL_CORE_VERSION < 10 typedef PDL_Long PDL_Indx; #endif /* avoid annoying warnings */ typedef PDL_Long logical; typedef PDL_Long integer; typedef PDL_Long ftnlen; #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif #ifndef min #define min(a,b) ((a) <= (b) ? (a) : (b)) #endif #ifndef max #define max(a,b) ((a) >= (b) ? (a) : (b)) #endif static integer c_zero = 0; static integer c_nine = 9; '); pp_addpm({At=>'Top'},<<'EOD'); use strict; { package # hide from CPAN PDL; my $warningFlag; BEGIN{ $warningFlag = $^W; $^W = 0; } use overload ( 'x' => sub {PDL::mmult($_[0], $_[1])}, ); BEGIN{ $^W = $warningFlag;} } =encoding Latin-1 =head1 NAME PDL::LinearAlgebra::Real - PDL interface to the real lapack linear algebra programming library =head1 SYNOPSIS use PDL::LinearAlgebra::Real; $a = random (100,100); $s = zeroes(100); $u = zeroes(100,100); $v = zeroes(100,100); $info = 0; $job = 0; gesdd($a, $job, $info, $s , $u, $v); Blas vector routine use increment. =head1 DESCRIPTION This module provides an interface to parts of the real lapack library. These routines accept either float or double piddles. EOD pp_def("gesvd", HandleBad => 0, RedoDimsCode => '$SIZE(r) = $PDL(A)->ndims > 1 ? min($PDL(A)->dims[0], $PDL(A)->dims[1]) : 1;', Pars => '[io,phys]A(m,n); int jobu(); int jobvt(); [o,phys]s(r); [o,phys]U(p,q); [o,phys]VT(s,t); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' types(F) %{ extern int sgesvd_(char *jobu, char *jobvt, integer *m, integer *n, float *a, integer *lda, float *s, float *u, int *ldu, float *vt, integer *ldvt, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgesvd_(char *jobz,char *jobvt, integer *m, integer *n, double *a, integer *lda, double *s, double *u, int *ldu, double *vt, integer *ldvt, double *work, integer *lwork, integer *info); double tmp_work; %} integer lwork = -1; char trau, travt; switch ($jobu()) { case 1: trau = \'A\'; break; case 2: trau = \'S\'; break; case 3: trau = \'O\'; break; default: trau = \'N\'; } switch ($jobvt()) { case 1: travt = \'A\'; break; case 2: travt = \'S\'; break; case 3: travt = \'O\'; break; default: travt = \'N\'; } $TFD(sgesvd_,dgesvd_)( &trau, &travt, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(s), $P(U), &(integer){$PRIV(__p_size)}, $P(VT), &(integer){$PRIV(__s_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgesvd_,dgesvd_)( &trau, &travt, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(s), $P(U), &(integer){$PRIV(__p_size)}, $P(VT), &(integer){$PRIV(__s_size)}, work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes the singular value decomposition (SVD) of a real M-by-N matrix A. The SVD is written A = U * SIGMA * V\' where SIGMA is an M-by-N matrix which is zero except for its min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA are the singular values of A; they are real and non-negative, and are returned in descending order. The first min(m,n) columns of U and V are the left and right singular vectors of A. Note that the routine returns VT = V\', not V. jobu: Specifies options for computing all or part of the matrix U: = 0: no columns of U (no left singular vectors) are computed. = 1: all M columns of U are returned in array U: = 2: the first min(m,n) columns of U (the left singular vectors) are returned in the array U; = 3: the first min(m,n) columns of U (the left singular vectors) are overwritten on the array A; jobvt: Specifies options for computing all or part of the matrix V\': = 0: no rows of V\' (no right singular vectors) are computed. = 1: all N rows of V\' are returned in the array VT; = 2: the first min(m,n) rows of V\' (the right singular vectors) are returned in the array VT; = 3: the first min(m,n) rows of V\' (the right singular vectors) are overwritten on the array A; jobvt and jobu cannot both be 3. A: On entry, the M-by-N matrix A. On exit, if jobu = 3, A is overwritten with the first min(m,n) columns of U (the left singular vectors, stored columnwise); if jobvt = 3, A is overwritten with the first min(m,n) rows of V\' (the right singular vectors, stored rowwise); if jobu != 3 and jobvt != 3, the contents of A are destroyed. s: The singular values of A, sorted so that s(i) >= s(i+1). U: If jobu = 1, U contains the M-by-M orthogonal matrix U; if jobu = 3, U contains the first min(m,n) columns of U (the left singular vectors, stored columnwise); if jobu = 0 or 3, U is not referenced. Min size = [1,1]. VT: If jobvt = 1, VT contains the N-by-N orthogonal matrix V\'; if jobvt = 2, VT contains the first min(m,n) rows of V\' (the right singular vectors, stored rowwise); if jobvt = 0 or 3, VT is not referenced. Min size = [1,1]. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. > 0: if bdsqr did not converge, info specifies how many superdiagonals of an intermediate bidiagonal form B did not converge to zero. =for example $a = random (float, 100,100); $s = zeroes(float, 100); $u = zeroes(float, 100,100); $vt = zeroes(float, 100,100); $info = pdl(long, 0); gesvd($a, 2, 2, $s , $u, $vt, $info); '); pp_def("gesdd", HandleBad => 0, RedoDimsCode => '$SIZE(r) = $PDL(A)->ndims > 1 ? min($PDL(A)->dims[0], $PDL(A)->dims[1]) : 1;', Pars => '[io,phys]A(m,n); int job(); [o,phys]s(r); [o,phys]U(p,q); [o,phys]VT(s,t); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork; integer *iwork; integer smlsiz; char tra; types(F) %{ extern int sgesdd_(char *jobz, integer *m, integer *n, float * a, integer *lda, float *s, float *u, int *ldu, float *vt, integer *ldvt, float *work, integer *lwork, integer *iwork, integer *info); float tmp_work; %} types(D) %{ extern int dgesdd_(char *jobz, integer *m, integer *n, double * a, integer *lda, double *s, double *u, int *ldu, double *vt, integer *ldvt, double *work, integer *lwork, integer *iwork, integer *info); double tmp_work; %} lwork = ($PRIV(__m_size) < $PRIV(__n_size)) ? 8*$PRIV(__m_size) : 8*$PRIV(__n_size); iwork = (integer *)malloc(lwork * sizeof(integer)); lwork = -1; switch ($job()) { case 1: tra = \'A\'; break; case 2: tra = \'S\'; break; case 3: tra = \'O\'; break; default: tra = \'N\'; break; } $TFD(sgesdd_,dgesdd_)( &tra, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(s), $P(U), &(integer){$PRIV(__p_size)}, $P(VT), &(integer){$PRIV(__s_size)}, &tmp_work, &lwork, iwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work; if (tra == \'N\'){ smlsiz = ilaenv_(&c_nine, "SGESDD", " ", &c_zero, &c_zero, &c_zero, &c_zero, (ftnlen)6, (ftnlen)1); lwork = max(14*min($PRIV(__m_size),$PRIV(__n_size))+4, 10*min($PRIV(__m_size), $PRIV(__n_size))+2+ smlsiz*(smlsiz+8)) + max($PRIV(__m_size),$PRIV(__n_size)); } work = (float *) malloc(lwork * sizeof(float)); %} types(D) %{ double *work; if (tra == \'N\'){ smlsiz = ilaenv_(&c_nine, "DGESDD", " ", &c_zero, &c_zero, &c_zero, &c_zero, (ftnlen)6, (ftnlen)1); lwork = max(14*min($PRIV(__m_size),$PRIV(__n_size))+4, 10*min($PRIV(__m_size), $PRIV(__n_size))+2+ smlsiz*(smlsiz+8)) + max($PRIV(__m_size),$PRIV(__n_size)); } work = (double *) malloc(lwork * sizeof(double)); %} $TFD(sgesdd_,dgesdd_)( &tra, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(s), $P(U), &(integer){$PRIV(__p_size)}, $P(VT), &(integer){$PRIV(__s_size)}, work, &lwork, iwork, $P(info)); free(work); } free(iwork); ', Doc => ' =for ref Computes the singular value decomposition (SVD) of a real M-by-N matrix A. This routine use the Coppen\'s divide and conquer algorithm. It is much faster than the simple driver for large matrices, but uses more workspace. job: Specifies options for computing all or part of matrix: = 0: no columns of U or rows of V\' are computed; = 1: all M columns of U and all N rows of V\' are returned in the arrays U and VT; = 2: the first min(M,N) columns of U and the first min(M,N) rows of V\' are returned in the arrays U and VT; = 3: If M >= N, the first N columns of U are overwritten on the array A and all rows of V\' are returned in the array VT; otherwise, all columns of U are returned in the array U and the first M rows of V\' are overwritten on the array A. A: On entry, the M-by-N matrix A. On exit, if job = 3, A is overwritten with the first N columns of U (the left singular vectors, stored columnwise) if M >= N; A is overwritten with the first M rows of V\' (the right singular vectors, stored rowwise) otherwise. if job != 3, the contents of A are destroyed. s: The singular values of A, sorted so that s(i) >= s(i+1). U: If job = 1 or job = 3 and M < N, U contains the M-by-M orthogonal matrix U; if job = 2, U contains the first min(M,N) columns of U (the left singular vectors, stored columnwise); if job = 3 and M >= N, or job = 0, U is not referenced. Min size = [1,1]. VT: If job = 1 or job = 3 and M >= N, VT contains the N-by-N orthogonal matrix V\'; if job = 2, VT contains the first min(M,N) rows of V\' (the right singular vectors, stored rowwise); if job = 3 and M < N, or job = 0, VT is not referenced. Min size = [1,1]. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. > 0: bdsdc did not converge, updating process failed. =for example $lines = 50; $columns = 100; $a = random (float, $lines, $columns); $min = $lines < $columns ? $lines : $columns; $s = zeroes(float, $min); $u = zeroes(float, $lines, $lines); $vt = zeroes(float, $columns, $columns); $info = long (0); gesdd($a, 1, $s , $u, $vt, $info); '); pp_def("ggsvd", HandleBad => 0, Pars => '[io,phys]A(m,n); int jobu(); int jobv(); int jobq(); [io,phys]B(p,n); int [o,phys]k(); int [o,phys]l();[o,phys]alpha(n);[o,phys]beta(n); [o,phys]U(q,r); [o,phys]V(s,t); [o,phys]Q(u,v); int [o,phys]iwork(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pjobu = \'N\'; char pjobv = \'N\'; char pjobq = \'N\'; types(F) %{ extern int sggsvd_(char *jobu, char *jobv, char *jobq, integer *m, integer *n, integer *p, integer *k, integer *l, float *a, integer *lda, float *b, integer *ldb, float *alpha, float *beta, float *u, integer *ldu, float *v, integer *ldv, float *q, integer *ldq, float *work, integer *iwork, integer *info); float *work; %} types(D) %{ extern int dggsvd_(char *jobu, char *jobv, char *jobq, integer *m, integer *n, integer *p, integer *k, integer *l, double *a, integer *lda, double *b, integer *ldb, double *alpha, double *beta, double *u, integer *ldu, double *v, integer *ldv, double *q, integer *ldq, double *work, integer *iwork, integer *info); double *work; %} integer lwork = ($SIZE (m) < $SIZE (n)) ? $SIZE (n): $SIZE (m); if ($SIZE (p) > lwork) lwork = $SIZE (p); types(F) %{ work = (float *)malloc((3*lwork + $SIZE (n))* sizeof(float)); %} types(D) %{ work = (double *)malloc((3*lwork + $SIZE (n)) * sizeof(double)); %} if ($jobu()) pjobu = \'U\'; if ($jobv()) pjobv = \'V\'; if ($jobq()) pjobq = \'Q\'; $TFD(sggsvd_,dggsvd_)( &pjobu, &pjobv, &pjobq, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__p_size)}, $P(k), $P(l), $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(alpha), $P(beta), $P(U), &(integer){$PRIV(__q_size)}, $P(V), &(integer){$PRIV(__s_size)}, $P(Q), &(integer){$PRIV(__u_size)}, work, $P(iwork), $P(info)); free(work); ', Doc => ' =for ref Computes the generalized singular value decomposition (GSVD) of an M-by-N real matrix A and P-by-N real matrix B: U\'*A*Q = D1*( 0 R ), V\'*B*Q = D2*( 0 R ) where U, V and Q are orthogonal matrices, and Z\' is the transpose of Z. Let K+L = the effective numerical rank of the matrix (A\',B\')\', then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the following structures, respectively: If M-K-L >= 0, K L D1 = K ( I 0 ) L ( 0 C ) M-K-L ( 0 0 ) K L D2 = L ( 0 S ) P-L ( 0 0 ) N-K-L K L ( 0 R ) = K ( 0 R11 R12 ) L ( 0 0 R22 ) where C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), S = diag( BETA(K+1), ... , BETA(K+L) ), C**2 + S**2 = I. R is stored in A(1:K+L,N-K-L+1:N) on exit. If M-K-L < 0, K M-K K+L-M D1 = K ( I 0 0 ) M-K ( 0 C 0 ) K M-K K+L-M D2 = M-K ( 0 S 0 ) K+L-M ( 0 0 I ) P-L ( 0 0 0 ) N-K-L K M-K K+L-M ( 0 R ) = K ( 0 R11 R12 R13 ) M-K ( 0 0 R22 R23 ) K+L-M ( 0 0 0 R33 ) where C = diag( ALPHA(K+1), ... , ALPHA(M) ), S = diag( BETA(K+1), ... , BETA(M) ), C**2 + S**2 = I. (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored ( 0 R22 R23 ) in B(M-K+1:L,N+M-K-L+1:N) on exit. The routine computes C, S, R, and optionally the orthogonal transformation matrices U, V and Q. In particular, if B is an N-by-N nonsingular matrix, then the GSVD of A and B implicitly gives the SVD of A*inv(B): A*inv(B) = U*(D1*inv(D2))*V\'. If ( A\',B\')\' has orthonormal columns, then the GSVD of A and B is also equal to the CS decomposition of A and B. Furthermore, the GSVD can be used to derive the solution of the eigenvalue problem: A\'*A x = lambda* B\'*B x. In some literature, the GSVD of A and B is presented in the form U\'*A*X = ( 0 D1 ), V\'*B*X = ( 0 D2 ) where U and V are orthogonal and X is nonsingular, D1 and D2 are "diagonal". The former GSVD form can be converted to the latter form by taking the nonsingular matrix X as X = Q*( I 0 ) ( 0 inv(R) ). Arguments ========= jobu: = 0: U is not computed. = 1: Orthogonal matrix U is computed; jobv: = 0: V is not computed. = 1: Orthogonal matrix V is computed; jobq: = 0: Q is not computed. = 1: Orthogonal matrix Q is computed; k: l: On exit, k and l specify the dimension of the subblocks described in the Purpose section. k + l = effective numerical rank of (A\',B\')\'. A: On entry, the M-by-N matrix A. On exit, A contains the triangular matrix R, or part of R. B: On entry, the P-by-N matrix B. On exit, B contains the triangular matrix R if M-k-l < 0. alpha: beta: On exit, alpha and beta contain the generalized singular value pairs of A and B; alpha(1:k) = 1, beta(1:k) = 0, and if M-k-l >= 0, alpha(k+1:k+l) = C, beta(k+1:k+l) = S, or if M-k-l < 0, alpha(k+1:M)=C, alpha(M+1:k+l)=0 beta(k+1:M) =S, beta(M+1:k+l) =1 and alpha(k+l+1:N) = 0 beta(k+l+1:N) = 0 U: If jobu = 1, U contains the M-by-M orthogonal matrix U. If jobu = 0, U is not referenced. Need a minimum array of (1,1) if jobu = 0; V: If jobv = 1, V contains the P-by-P orthogonal matrix V. If jobv = 0, V is not referenced. Need a minimum array of (1,1) if jobv = 0; Q: If jobq = 1, Q contains the N-by-N orthogonal matrix Q. If jobq = 0, Q is not referenced. Need a minimum array of (1,1) if jobq = 0; iwork: On exit, iwork stores the sorting information. More precisely, the following loop will sort alpha for I = k+1, min(M,k+l) swap alpha(I) and alpha(iwork(I)) endfor such that alpha(1) >= alpha(2) >= ... >= alpha(N). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: if info = 1, the Jacobi-type procedure failed to converge. For further details, see subroutine tgsja. =for example $k = null; $l = null; $A = random(5,6); $B = random(7,6); $alpha = zeroes(6); $beta = zeroes(6); $U = zeroes(5,5); $V = zeroes(7,7); $Q = zeroes(6,6); $iwork = zeroes(long, 6); $info = null; ggsvd($A,1,1,1,$B,$k,$l,$alpha, $beta,$U, $V, $Q, $iwork,$info); '); pp_def("geev", HandleBad => 0, Pars => '[phys]A(n,n); int jobvl(); int jobvr(); [o,phys]wr(n); [o,phys]wi(n); [o,phys]vl(m,m); [o,phys]vr(p,p); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jvl = \'N\'; char jvr = \'N\'; types(F) %{ extern int sgeev_(char *jobvl, char *jobvr, integer *n, float *a, integer *lda, float *wr, float *wi, float *vl, integer *ldvl, float *vr, integer *ldvr, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgeev_(char *jobvl, char *jobvr, integer *n, double * a, integer *lda, double *wr, double *wi, double *vl, integer *ldvl, double *vr, integer *ldvr, double *work, integer *lwork, integer *info); double tmp_work; %} integer lwork = -1; if ($jobvl()) jvl = \'V\'; if ($jobvr()) jvr = \'V\'; $TFD(sgeev_,dgeev_)( &jvl, &jvr, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(wr), $P(wi), $P(vl), &(integer){$PRIV(__m_size)}, $P(vr), &(integer){$PRIV(__p_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgeev_,dgeev_)( &jvl, &jvr, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(wr), $P(wi), $P(vl), &(integer){$PRIV(__m_size)}, $P(vr), &(integer){$PRIV(__p_size)}, work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes for an N-by-N real nonsymmetric matrix A, the eigenvalues and, optionally, the left and/or right eigenvectors. The right eigenvector v(j) of A satisfies: A * v(j) = lambda(j) * v(j) where lambda(j) is its eigenvalue. The left eigenvector u(j) of A satisfies: u(j)**H * A = lambda(j) * u(j)**H where u(j)**H denotes the conjugate transpose of u(j). The computed eigenvectors are normalized to have Euclidean norm equal to 1 and largest component real. Arguments ========= jobvl: = 0: left eigenvectors of A are not computed; = 1: left eigenvectors of A are computed. jobvr: = 0: right eigenvectors of A are not computed; = 1: right eigenvectors of A are computed. A: A is overwritten. wr: wi: wr and wi contain the real and imaginary parts, respectively, of the computed eigenvalues. Complex conjugate pairs of eigenvalues appear consecutively with the eigenvalue having the positive imaginary part first. vl: If jobvl = 1, the left eigenvectors u(j) are stored one after another in the columns of vl, in the same order as their eigenvalues else vl is not referenced. If the j-th eigenvalue is real, then u(j) = vl(:,j), the j-th column of vl. If the j-th and (j+1)-st eigenvalues form a complex conjugate pair, then u(j) = vl(:,j) + i*vl(:,j+1) and u(j+1) = vl(:,j) - i*vl(:,j+1). Min size = [1]. vr: If jobvr = 1, the right eigenvectors v(j) are stored one after another in the columns of vr, in the same order as their eigenvalues else vr is not referenced. If the j-th eigenvalue is real, then v(j) = vr(:,j), the j-th column of vr. If the j-th and (j+1)-st eigenvalues form a complex conjugate pair, then v(j) = vr(:,j) + i*vr(:,j+1) and v(j+1) = vr(:,j) - i*vr(:,j+1). Min size = [1]. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: if info = i, the QR algorithm failed to compute all the eigenvalues, and no eigenvectors have been computed; elements i+1:N of wr and wi contain eigenvalues which have converged. =for example $a = random (5, 5); $wr = zeroes(5); $wi = zeroes($wr); $vl = zeroes($a); $vr = zeroes($a); $info = null; geev($a, 1, 1, $wr, $wi, $vl, $vr, $info); '); pp_def("geevx", HandleBad => 0, Pars => '[io,phys]A(n,n); int jobvl(); int jobvr(); int balance(); int sense(); [o,phys]wr(n); [o,phys]wi(n); [o,phys]vl(m,m); [o,phys]vr(p,p); int [o,phys]ilo(); int [o,phys]ihi(); [o,phys]scale(n); [o,phys]abnrm(); [o,phys]rconde(q); [o,phys]rcondv(r); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jvl = \'N\'; char jvr = \'N\'; char balanc, sens; integer *iwork; integer lwork = -1; types(F) %{ extern int sgeevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, float *a, integer *lda, float *wr, float *wi, float *vl, integer *ldvl, float *vr, integer *ldvr, integer *ilo, integer *ihi, float *scale, float *abnrm, float *rconde, float *rcondv, float *work, integer *lwork, integer *iwork, integer *info); float tmp_work; %} types(D) %{ extern int dgeevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, double *a, integer *lda, double *wr, double *wi, double *vl, integer *ldvl, double *vr, integer *ldvr, integer *ilo, integer *ihi, double *scale, double *abnrm, double *rconde, double *rcondv, double *work, integer *lwork, integer *iwork, integer *info); double tmp_work; %} if ($jobvl()) jvl = \'V\'; if ($jobvr()) jvr = \'V\'; switch ($balance()) { case 1: balanc = \'P\'; break; case 2: balanc = \'S\'; break; case 3: balanc = \'B\'; break; default: balanc = \'N\'; } switch ($sense()) { case 1: sens = \'E\'; break; case 2: sens = \'V\'; iwork = (integer *)malloc ((2 * $PRIV(__n_size) -2)* sizeof (integer)); break; case 3: sens = \'B\'; iwork = (integer *)malloc ((2 * $PRIV(__n_size) -2)* sizeof (integer)); break; default: sens = \'N\'; } $TFD(sgeevx_,dgeevx_)( &balanc, &jvl, &jvr, &sens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(wr), $P(wi), $P(vl), &(integer){$PRIV(__m_size)}, $P(vr), &(integer){$PRIV(__p_size)}, $P(ilo), $P(ihi), $P(scale), $P(abnrm), $P(rconde), $P(rcondv), &tmp_work, &lwork, iwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgeevx_,dgeevx_)( &balanc, &jvl, &jvr, &sens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(wr), $P(wi), $P(vl), &(integer){$PRIV(__m_size)}, $P(vr), &(integer){$PRIV(__p_size)}, $P(ilo), $P(ihi), $P(scale), $P(abnrm), $P(rconde), $P(rcondv), work, &lwork, iwork, $P(info)); free(work); } if ($sense() == 2 || $sense() == 3) free(iwork); ', Doc => ' =for ref Computes for an N-by-N real nonsymmetric matrix A, the eigenvalues and, optionally, the left and/or right eigenvectors. Optionally also, it computes a balancing transformation to improve the conditioning of the eigenvalues and eigenvectors (ilo, ihi, scale, and abnrm), reciprocal condition numbers for the eigenvalues (rconde), and reciprocal condition numbers for the right eigenvectors (rcondv). The right eigenvector v(j) of A satisfies: A * v(j) = lambda(j) * v(j) where lambda(j) is its eigenvalue. The left eigenvector u(j) of A satisfies: u(j)**H * A = lambda(j) * u(j)**H where u(j)**H denotes the conjugate transpose of u(j). The computed eigenvectors are normalized to have Euclidean norm equal to 1 and largest component real. Balancing a matrix means permuting the rows and columns to make it more nearly upper triangular, and applying a diagonal similarity transformation D * A * D**(-1), where D is a diagonal matrix, to make its rows and columns closer in norm and the condition numbers of its eigenvalues and eigenvectors smaller. The computed reciprocal condition numbers correspond to the balanced matrix. Permuting rows and columns will not change the condition numbers (in exact arithmetic) but diagonal scaling will. For further explanation of balancing, see section 4.10.2 of the LAPACK Users\' Guide. Arguments ========= balance: Indicates how the input matrix should be diagonally scaled and/or permuted to improve the conditioning of its eigenvalues. = 0: Do not diagonally scale or permute; = 1: Perform permutations to make the matrix more nearly upper triangular. Do not diagonally scale; = 2: Diagonally scale the matrix, i.e. replace A by D*A*D**(-1), where D is a diagonal matrix chosen to make the rows and columns of A more equal in norm. Do not permute; = 3: Both diagonally scale and permute A. Computed reciprocal condition numbers will be for the matrix after balancing and/or permuting. Permuting does not change condition numbers (in exact arithmetic), but balancing does. jobvl: = 0: left eigenvectors of A are not computed; = 1: left eigenvectors of A are computed. If sense = 1 or 3, jobvl must = 1. jobvr; = 0: right eigenvectors of A are not computed; = 1: right eigenvectors of A are computed. If sense = 1 or 3, jobvr must = 1. sense: Determines which reciprocal condition numbers are computed. = 0: None are computed; = 1: Computed for eigenvalues only; = 2: Computed for right eigenvectors only; = 3: Computed for eigenvalues and right eigenvectors. If sense = 1 or 3, both left and right eigenvectors must also be computed (jobvl = 1 and jobvr = 1). A: The N-by-N matrix. It is overwritten. If jobvl = 1 or jobvr = 1, A contains the real Schur form of the balanced version of the input matrix A. wr wi: wr and wi contain the real and imaginary parts, respectively, of the computed eigenvalues. Complex conjugate pairs of eigenvalues will appear consecutively with the eigenvalue having the positive imaginary part first. vl: If jobvl = 1, the left eigenvectors u(j) are stored one after another in the columns of vl, in the same order as their eigenvalues else vl is not referenced. If the j-th eigenvalue is real, then u(j) = vl(:,j), the j-th column of vl. If the j-th and (j+1)-st eigenvalues form a complex conjugate pair, then u(j) = vl(:,j) + i*vl(:,j+1) and u(j+1) = vl(:,j) - i*vl(:,j+1). Min size = [1]. vr: If jobvr = 1, the right eigenvectors v(j) are stored one after another in the columns of vr, in the same order as their eigenvalues else vr is not referenced. If the j-th eigenvalue is real, then v(j) = vr(:,j), the j-th column of vr. If the j-th and (j+1)-st eigenvalues form a complex conjugate pair, then v(j) = vr(:,j) + i*vr(:,j+1) and v(j+1) = vr(:,j) - i*vr(:,j+1). Min size = [1]. ilo,ihi:Integer values determined when A was balanced. The balanced A(i,j) = 0 if I > J and J = 1,...,ilo-1 or I = ihi+1,...,N. scale: Details of the permutations and scaling factors applied when balancing A. If P(j) is the index of the row and column interchanged with row and column j, and D(j) is the scaling factor applied to row and column j, then scale(J) = P(J), for J = 1,...,ilo-1 = D(J), for J = ilo,...,ihi = P(J) for J = ihi+1,...,N. The order in which the interchanges are made is N to ihi+1, then 1 to ilo-1. abnrm: The one-norm of the balanced matrix (the maximum of the sum of absolute values of elements of any column). rconde: rconde(j) is the reciprocal condition number of the j-th eigenvalue. rcondv: rcondv(j) is the reciprocal condition number of the j-th right eigenvector. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: if info = i, the QR algorithm failed to compute all the eigenvalues, and no eigenvectors or condition numbers have been computed; elements 1:ilo-1 and i+1:N of wr and wi contain eigenvalues which have converged. =for example $a = random (5,5); $wr = zeroes(5); $wi = zeroes(5); $vl = zeroes(5,5); $vr = zeroes(5,5); $ilo = null; $ihi = null; $scale = zeroes(5); $abnrm = null; $rconde = zeroes(5); $rcondv = zeroes(5); $info = null; geevx($a, 1,1,3,3,$wr, $wi, $vl, $vr, $ilo, $ihi, $scale, $abnrm,$rconde, $rcondv, $info); '); pp_def("ggev", HandleBad => 0, Pars => '[phys]A(n,n); int jobvl();int jobvr();[phys]B(n,n);[o,phys]alphar(n);[o,phys]alphai(n);[o,phys]beta(n);[o,phys]VL(m,m);[o,phys]VR(p,p);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; char pjobvl = \'N\', pjobvr = \'N\'; types(F) %{ extern int sggev_(char *jobvl, char *jobvr, integer *n, float * a, integer *lda, float *b, integer *ldb, float *alphar, float *alphai, float *beta, float *vl, integer *ldvl, float *vr, integer *ldvr, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dggev_(char *jobvl, char *jobvr, integer *n, double * a, integer *lda, double *b, integer *ldb, double *alphar, double *alphai, double *beta, double *vl, integer *ldvl, double *vr, integer *ldvr, double *work, integer *lwork, integer *info); double tmp_work; %} if ($jobvl()) pjobvl = \'V\'; if ($jobvr()) pjobvr = \'V\'; $TFD(sggev_,dggev_)( &pjobvl, &pjobvr, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(alphar), $P(alphai), $P(beta), $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sggev_,dggev_)( &pjobvl, &pjobvr, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(alphar), $P(alphai), $P(beta), $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes for a pair of N-by-N real nonsymmetric matrices (A,B) the generalized eigenvalues, and optionally, the left and/or right generalized eigenvectors. A generalized eigenvalue for a pair of matrices (A,B) is a scalar lambda or a ratio alpha/beta = lambda, such that A - lambda*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0, and even for both being zero. The right eigenvector v(j) corresponding to the eigenvalue lambda(j) of (A,B) satisfies A * v(j) = lambda(j) * B * v(j). The left eigenvector u(j) corresponding to the eigenvalue lambda(j) of (A,B) satisfies u(j)**H * A = lambda(j) * u(j)**H * B . where u(j)**H is the conjugate-transpose of u(j). Arguments ========= jobvl: = 0: do not compute the left generalized eigenvectors; = 1: compute the left generalized eigenvectors. jobvr: = 0: do not compute the right generalized eigenvectors; = 1: compute the right generalized eigenvectors. A: On entry, the matrix A in the pair (A,B). On exit, A has been overwritten. B: On entry, the matrix B in the pair (A,B). On exit, B has been overwritten. alphar: alphai: beta: On exit, (alphar(j) + alphai(j)*i)/beta(j), j=1,...,N, will be the generalized eigenvalues. If alphai(j) is zero, then the j-th eigenvalue is real; if positive, then the j-th and (j+1)-st eigenvalues are a complex conjugate pair, with alphai(j+1) negative. Note: the quotients alphar(j)/beta(j) and alphai(j)/beta(j) may easily over- or underflow, and beta(j) may even be zero. Thus, the user should avoid naively computing the ratio alpha/beta. However, alphar and alphai will be always less than and usually comparable with norm(A) in magnitude, and beta always less than and usually comparable with norm(B). VL: If jobvl = 1, the left eigenvectors u(j) are stored one after another in the columns of VL, in the same order as their eigenvalues. If the j-th eigenvalue is real, then u(j) = VL(:,j), the j-th column of VL. If the j-th and (j+1)-th eigenvalues form a complex conjugate pair, then u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). Each eigenvector will be scaled so the largest component have abs(real part)+abs(imag. part)=1. Not referenced if jobvl = 0. VR: If jobvr = 1, the right eigenvectors v(j) are stored one after another in the columns of VR, in the same order as their eigenvalues. If the j-th eigenvalue is real, then v(j) = VR(:,j), the j-th column of VR. If the j-th and (j+1)-th eigenvalues form a complex conjugate pair, then v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). Each eigenvector will be scaled so the largest component have abs(real part)+abs(imag. part)=1. Not referenced if jobvr = 0. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. = 1,...,N: The QZ iteration failed. No eigenvectors have been calculated, but alphar(j), alphai(j), and beta(j) should be correct for j=info+1,...,N. > N: =N+1: other than QZ iteration failed in hgeqz. =N+2: error return from tgevc. =for example $a = random(5,5); $b = random(5,5); $alphar = zeroes(5); $alphai = zeroes(5); $beta = zeroes(5); $vl = zeroes(5,5); $vr = zeroes(5,5); ggev($a, 1, 1, $b, $alphar, $alphai, $beta, $vl, $vr, ($info=null)); '); pp_def("ggevx", HandleBad => 0, Pars => '[io,phys]A(n,n);int balanc();int jobvl();int jobvr();int sense();[io,phys]B(n,n);[o,phys]alphar(n);[o,phys]alphai(n);[o,phys]beta(n);[o,phys]VL(m,m);[o,phys]VR(p,p);int [o,phys]ilo();int [o,phys]ihi();[o,phys]lscale(n);[o,phys]rscale(n);[o,phys]abnrm();[o,phys]bbnrm();[o,phys]rconde(r);[o,phys]rcondv(s);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1, *iwork, *bwork; char pjobvl = \'N\', pjobvr = \'N\'; char pbalanc, psens; types(F) %{ int sggevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, float *a, integer *lda, float *b, integer *ldb, float *alphar, float *alphai, float * beta, float *vl, integer *ldvl, float *vr, integer *ldvr, integer *ilo, integer *ihi, float *lscale, float *rscale, float *abnrm, float *bbnrm, float *rconde, float * rcondv, float *work, integer *lwork, integer *iwork, logical * bwork, integer *info); float tmp_work; %} types(D) %{ extern int dggevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, double *a, integer *lda, double *b, integer *ldb, double *alphar, double *alphai, double * beta, double *vl, integer *ldvl, double *vr, integer *ldvr, integer *ilo, integer *ihi, double *lscale, double *rscale, double *abnrm, double *bbnrm, double *rconde, double * rcondv, double *work, integer *lwork, integer *iwork, logical * bwork, integer *info); double tmp_work; %} if ($jobvl()) pjobvl = \'V\'; if ($jobvr()) pjobvr = \'V\'; switch ($balanc()) { case 1: pbalanc = \'P\'; break; case 2: pbalanc = \'S\'; break; case 3: pbalanc = \'B\'; break; default: pbalanc = \'N\'; } switch ($sense()) { case 1: psens = \'E\'; bwork = (integer *)malloc($SIZE(n) * sizeof(integer)); break; case 2: psens = \'V\'; iwork = (integer *)malloc(($SIZE(n) + 6) * sizeof(integer)); bwork = (integer *)malloc($SIZE(n) * sizeof(integer)); break; case 3: psens = \'B\'; iwork = (integer *)malloc(($SIZE(n) + 6) * sizeof(integer)); bwork = (integer *)malloc($SIZE(n) * sizeof(integer)); break; default: psens = \'N\'; iwork = (integer *)malloc(($SIZE(n) + 6) * sizeof(integer)); } $TFD(sggevx_,dggevx_)( &pbalanc, &pjobvl, &pjobvr, &psens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(alphar), $P(alphai), $P(beta), $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, $P(ilo), $P(ihi), $P(lscale), $P(rscale), $P(abnrm), $P(bbnrm), $P(rconde), $P(rcondv), &tmp_work, &lwork, iwork, bwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sggevx_,dggevx_)( &pbalanc, &pjobvl, &pjobvr, &psens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(alphar), $P(alphai), $P(beta), $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, $P(ilo), $P(ihi), $P(lscale), $P(rscale), $P(abnrm), $P(bbnrm), $P(rconde), $P(rcondv), work, &lwork, iwork, bwork, $P(info)); free(work); } if ($sense()) free(bwork); if ($sense() != 1) free(iwork); ', Doc => ' =for ref Computes for a pair of N-by-N real nonsymmetric matrices (A,B) the generalized eigenvalues, and optionally, the left and/or right generalized eigenvectors. Optionally also, it computes a balancing transformation to improve the conditioning of the eigenvalues and eigenvectors (ilo, ihi, lscale, rscale, abnrm, and bbnrm), reciprocal condition numbers for the eigenvalues (rconde), and reciprocal condition numbers for the right eigenvectors (rcondv). A generalized eigenvalue for a pair of matrices (A,B) is a scalar lambda or a ratio alpha/beta = lambda, such that A - lambda*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0, and even for both being zero. The right eigenvector v(j) corresponding to the eigenvalue lambda(j) of (A,B) satisfies A * v(j) = lambda(j) * B * v(j) . The left eigenvector u(j) corresponding to the eigenvalue lambda(j) of (A,B) satisfies u(j)**H * A = lambda(j) * u(j)**H * B. where u(j)**H is the conjugate-transpose of u(j). Further Details =============== Balancing a matrix pair (A,B) includes, first, permuting rows and columns to isolate eigenvalues, second, applying diagonal similarity transformation to the rows and columns to make the rows and columns as close in norm as possible. The computed reciprocal condition numbers correspond to the balanced matrix. Permuting rows and columns will not change the condition numbers (in exact arithmetic) but diagonal scaling will. For further explanation of balancing, see section 4.11.1.2 of LAPACK Users\' Guide. An approximate error bound on the chordal distance between the i-th computed generalized eigenvalue w and the corresponding exact eigenvalue lambda is chord(w, lambda) <= EPS * norm(abnrm, bbnrm) / rconde(I) An approximate error bound for the angle between the i-th computed eigenvector vl(i) or vr(i) is given by EPS * norm(abnrm, bbnrm) / DIF(i). For further explanation of the reciprocal condition numbers rconde and rcondv, see section 4.11 of LAPACK User\'s Guide. Arguments ========= balanc: Specifies the balance option to be performed. = 0: do not diagonally scale or permute; = 1: permute only; = 2: scale only; = 3: both permute and scale. Computed reciprocal condition numbers will be for the matrices after permuting and/or balancing. Permuting does not change condition numbers (in exact arithmetic), but balancing does. jobvl: = 0: do not compute the left generalized eigenvectors; = 1: compute the left generalized eigenvectors. jobvr: = 0: do not compute the right generalized eigenvectors; = 1: compute the right generalized eigenvectors. sense: Determines which reciprocal condition numbers are computed. = 0: none are computed; = 1: computed for eigenvalues only; = 2: computed for eigenvectors only; = 3: computed for eigenvalues and eigenvectors. A: On entry, the matrix A in the pair (A,B). On exit, A has been overwritten. If jobvl=1 or jobvr=1 or both, then A contains the first part of the real Schur form of the "balanced" versions of the input A and B. B: On entry, the matrix B in the pair (A,B). On exit, B has been overwritten. If jobvl=1 or jobvr=1 or both, then B contains the second part of the real Schur form of the "balanced" versions of the input A and B. alphar: alphai: beta: On exit, (alphar(j) + alphai(j)*i)/beta(j), j=1,...,N, will be the generalized eigenvalues. If alphai(j) is zero, then the j-th eigenvalue is real; if positive, then the j-th and (j+1)-st eigenvalues are a complex conjugate pair, with alphai(j+1) negative. Note: the quotients alphar(j)/beta(j) and alphai(j)/beta(j) may easily over- or underflow, and beta(j) may even be zero. Thus, the user should avoid naively computing the ratio ALPHA/beta. However, alphar and alphai will be always less than and usually comparable with norm(A) in magnitude, and beta always less than and usually comparable with norm(B). vl: If jobvl = 1, the left eigenvectors u(j) are stored one after another in the columns of vl, in the same order as their eigenvalues. If the j-th eigenvalue is real, then u(j) = vl(:,j), the j-th column of vl. If the j-th and (j+1)-th eigenvalues form a complex conjugate pair, then u(j) = vl(:,j)+i*vl(:,j+1) and u(j+1) = vl(:,j)-i*vl(:,j+1). Each eigenvector will be scaled so the largest component have abs(real part) + abs(imag. part) = 1. Not referenced if jobvl = 0. vr: If jobvr = 1, the right eigenvectors v(j) are stored one after another in the columns of vr, in the same order as their eigenvalues. If the j-th eigenvalue is real, then v(j) = vr(:,j), the j-th column of vr. If the j-th and (j+1)-th eigenvalues form a complex conjugate pair, then v(j) = vr(:,j)+i*vr(:,j+1) and v(j+1) = vr(:,j)-i*vr(:,j+1). Each eigenvector will be scaled so the largest component have abs(real part) + abs(imag. part) = 1. Not referenced if jobvr = 0. ilo,ihi:ilo and ihi are integer values such that on exit A(i,j) = 0 and B(i,j) = 0 if i > j and j = 1,...,ilo-1 or i = ihi+1,...,N. If balanc = 0 or 2, ilo = 1 and ihi = N. lscale: Details of the permutations and scaling factors applied to the left side of A and B. If PL(j) is the index of the row interchanged with row j, and DL(j) is the scaling factor applied to row j, then lscale(j) = PL(j) for j = 1,...,ilo-1 = DL(j) for j = ilo,...,ihi = PL(j) for j = ihi+1,...,N. The order in which the interchanges are made is N to ihi+1, then 1 to ilo-1. rscale: Details of the permutations and scaling factors applied to the right side of A and B. If PR(j) is the index of the column interchanged with column j, and DR(j) is the scaling factor applied to column j, then rscale(j) = PR(j) for j = 1,...,ilo-1 = DR(j) for j = ilo,...,ihi = PR(j) for j = ihi+1,...,N The order in which the interchanges are made is N to ihi+1, then 1 to ilo-1. abnrm: The one-norm of the balanced matrix A. bbnrm: The one-norm of the balanced matrix B. rconde: If sense = 1 or 3, the reciprocal condition numbers of the selected eigenvalues, stored in consecutive elements of the array. For a complex conjugate pair of eigenvalues two consecutive elements of rconde are set to the same value. Thus rconde(j), rcondv(j), and the j-th columns of vl and vr all correspond to the same eigenpair (but not in general the j-th eigenpair, unless all eigenpairs are selected). If sense = 2, rconde is not referenced. rcondv: If sense = 2 or 3, the estimated reciprocal condition numbers of the selected eigenvectors, stored in consecutive elements of the array. For a complex eigenvector two consecutive elements of rcondv are set to the same value. If the eigenvalues cannot be reordered to compute rcondv(j), rcondv(j) is set to 0; this can only occur when the true value would be very small anyway. If sense = 1, rcondv is not referenced. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. = 1,...,N: The QZ iteration failed. No eigenvectors have been calculated, but alphar(j), alphai(j), and beta(j) should be correct for j=info+1,...,N. > N: =N+1: other than QZ iteration failed in hgeqz. =N+2: error return from tgevc. =for example $a = random(5,5); $b = random(5,5); $alphar = zeroes(5); $alphai = zeroes(5); $beta = zeroes(5); $vl = zeroes(5,5); $vr = zeroes(5,5); $lscale = zeroes(5); $rscale = zeroes(5); $ilo = null; $ihi = null; $abnrm = null; $bbnrm = null; $rconde = zeroes(5); $rcondv = zeroes(5); ggevx($a, 3, 1, 1, 3, $b, $alphar, $alphai, $beta, $vl, $vr, $ilo, $ihi, $lscale, $rscale, $abnrm, $bbnrm, $rconde,$rcondv,($info=null)); '); pp_addhdr(' static SV* fselect_function; PDL_Long fselection_wrapper(float *wr, float *wi) { dSP ; long choice; int retval; ENTER ; SAVETMPS ; PUSHMARK(sp) ; XPUSHs(sv_2mortal(newSVnv((double ) *wr))); XPUSHs(sv_2mortal(newSVnv((double ) *wi))); PUTBACK ; retval = perl_call_sv(fselect_function, G_SCALAR); SPAGAIN; if (retval != 1) croak("Error calling perl function\n"); choice = (long ) POPl ; /* Return value */ PUTBACK ; FREETMPS ; LEAVE ; return choice; } static SV* dselect_function; PDL_Long dselection_wrapper(double *wr, double *wi) { dSP ; long choice; int retval; ENTER ; SAVETMPS ; PUSHMARK(sp) ; XPUSHs(sv_2mortal(newSVnv(*wr))); XPUSHs(sv_2mortal(newSVnv(*wi))); PUTBACK ; retval = perl_call_sv(dselect_function, G_SCALAR); SPAGAIN; if (retval != 1) croak("Error calling perl function\n"); choice = (long ) POPl ; /* Return value */ PUTBACK ; FREETMPS ; LEAVE ; return choice; } '); pp_def("gees", HandleBad => 0, Pars => '[io,phys]A(n,n); int jobvs(); int sort(); [o,phys]wr(n); [o,phys]wi(n); [o,phys]vs(p,p); int [o,phys]sdim(); int [o,phys]info()', OtherPars => "SV* select_func" , GenericTypes => [F,D], Code => generate_code ' char jvs = \'N\'; char psort = \'N\'; integer *bwork; integer lwork = -1; types(F) %{ extern int sgees_(char *jobvs, char *sort, L_fp select, integer *n, float *a, integer *lda, integer *sdim, float *wr, float *wi, float *vs, integer *ldvs, float *work, integer *lwork, integer *bwork, integer *info); float tmp_work; fselect_function = $PRIV(select_func); %} types(D) %{ extern int dgees_(char *jobvs, char *sort, L_fp select, integer *n, double *a, integer *lda, integer *sdim, double *wr, double *wi, double *vs, integer *ldvs, double *work, integer *lwork, integer *bwork, integer *info); double tmp_work; dselect_function = $PRIV(select_func); %} if ($jobvs()) jvs = \'V\'; if ($sort()){ psort = \'S\'; bwork = (integer * ) malloc ($PRIV(__n_size) * sizeof (integer)); } types(F) %{ sgees_( &jvs, &psort, fselection_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(wr), $P(wi), $P(vs), &(integer){$PRIV(__p_size)}, &tmp_work, &lwork, bwork, $P(info)); %} types(D) %{ dgees_( &jvs, &psort, dselection_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(wr), $P(wi), $P(vs), &(integer){$PRIV(__p_size)}, &tmp_work, &lwork, bwork, $P(info)); %} lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} types(F) %{ sgees_( &jvs, &psort, fselection_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(wr), $P(wi), $P(vs), &(integer){$PRIV(__p_size)}, work, &lwork, bwork, $P(info)); %} types(D) %{ dgees_( &jvs, &psort, dselection_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(wr), $P(wi), $P(vs), &(integer){$PRIV(__p_size)}, work, &lwork, bwork, $P(info)); %} free(work); } if ($sort()) free(bwork); ', Doc => ' =for ref Computes for an N-by-N real nonsymmetric matrix A, the eigenvalues, the real Schur form T, and, optionally, the matrix of Schur vectors Z. This gives the Schur factorization A = Z*T*Z\'. Optionally, it also orders the eigenvalues on the diagonal of the real Schur form so that selected eigenvalues are at the top left. The leading columns of Z then form an orthonormal basis for the invariant subspace corresponding to the selected eigenvalues. A matrix is in real Schur form if it is upper quasi-triangular with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the form [ a b ] [ c a ] where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). Arguments ========= jobvs: = 0: Schur vectors are not computed; = 1: Schur vectors are computed. sort: Specifies whether or not to order the eigenvalues on the diagonal of the Schur form. = 0: Eigenvalues are not ordered; = 1: Eigenvalues are ordered (see select_func). select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form. If sort = 0, select_func is not referenced. An eigenvalue wr(j)+sqrt(-1)*wi(j) is selected if select_func(SCALAR(wr(j)), SCALAR(wi(j))) is true; i.e., if either one of a complex conjugate pair of eigenvalues is selected, then both complex eigenvalues are selected. Note that a selected complex eigenvalue may no longer satisfy select_func(wr(j),wi(j)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info is set to N+2 (see info below). A: The N-by-N matrix A. On exit, A has been overwritten by its real Schur form T. sdim: If sort = 0, sdim = 0. If sort = 1, sdim = number of eigenvalues (after sorting) for which select_func is true. (Complex conjugate pairs for which select_func is true for either eigenvalue count as 2.) wr: wi: wr and wi contain the real and imaginary parts, respectively, of the computed eigenvalues in the same order that they appear on the diagonal of the output Schur form T. Complex conjugate pairs of eigenvalues will appear consecutively with the eigenvalue having the positive imaginary part first. vs: If jobvs = 1, vs contains the orthogonal matrix Z of Schur vectors else vs is not referenced. info = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: if info = i, and i is <= N: the QR algorithm failed to compute all the eigenvalues; elements 1:ILO-1 and i+1:N of wr and wi contain those eigenvalues which have converged; if jobvs = 1, vs contains the matrix which reduces A to its partially converged Schur form. = N+1: the eigenvalues could not be reordered because some eigenvalues were too close to separate (the problem is very ill-conditioned); = N+2: after reordering, roundoff changed values of some complex eigenvalues so that leading eigenvalues in the Schur form no longer satisfy select_func = 1 This could also be caused by underflow due to scaling. =for example sub select_function{ my ($a, $b ) = @_; # Stable "continuous time" eigenspace return $a < 0 ? 1 : 0; } $A = random (5,5); $wr= zeroes(5); $wi = zeroes(5); $vs = zeroes(5,5); $sdim = null; $info = null; gees($A, 1,1, $wr, $wi, $vs, $sdim, $info,\&select_function); '); pp_def("geesx", HandleBad => 0, Pars => '[io,phys]A(n,n); int jobvs(); int sort(); int sense(); [o,phys]wr(n); [o,phys]wi(n); [o,phys]vs(p,p); int [o,phys]sdim(); [o,phys]rconde();[o,phys]rcondv(); int [o,phys]info()', OtherPars => "SV* select_func" , GenericTypes => [F,D], Code => generate_code ' char jvs = \'N\'; char psort = \'N\'; integer *bwork; integer lwork = 0; integer liwork = 1; integer *iwork; char sens; types(F) %{ extern int sgeesx_(char *jobvs, char *sort, L_fp select, char * sense, integer *n, float *a, integer *lda, integer *sdim, float *wr, float *wi, float *vs, integer *ldvs, float *rconde, float *rcondv, float *work, integer *lwork, integer *iwork, integer *liwork, integer *bwork, integer *info); float *work; fselect_function = $PRIV(select_func); %} types(D) %{ extern int dgeesx_(char *jobvs, char *sort, L_fp select, char * sense, integer *n, double *a, integer *lda, integer *sdim, double *wr, double *wi, double *vs, integer *ldvs, double *rconde, double *rcondv, double *work, integer *lwork, integer *iwork, integer *liwork, integer *bwork, integer *info); double *work; dselect_function = $PRIV(select_func); %} if ($jobvs()) jvs = \'V\'; if ($sort()){ psort = \'S\'; bwork = (integer * ) malloc ($PRIV(__n_size) * sizeof (integer)); } switch ($sense()) { case 1: sens = \'E\'; lwork = (integer ) ($PRIV(__n_size) + $PRIV(__n_size) * ($PRIV(__n_size)/2+1)); iwork = (integer *) malloc (liwork * sizeof (integer)); break; case 2: sens = \'V\'; lwork = (integer ) ($PRIV(__n_size) + $PRIV(__n_size) * ($PRIV(__n_size)/2+1)); if ($sort()){ liwork = (integer )(pow((($PRIV(__n_size)/2)+1), 2)); iwork = (integer *) malloc (liwork * sizeof (integer)); } else{iwork = (integer *) malloc (liwork * sizeof (integer));} break; case 3: sens = \'B\'; lwork = (integer ) ($PRIV(__n_size) + $PRIV(__n_size) * ($PRIV(__n_size)/2+1)); if ($sort()){ liwork = (integer )(pow((($PRIV(__n_size)/2)+1), 2)); iwork = (integer *) malloc (liwork * sizeof (integer)); } else{iwork = (integer *) malloc (liwork * sizeof (integer));} break; default: sens = \'N\'; lwork = (integer ) ($PRIV(__n_size) * 3); iwork = (integer *) malloc (liwork * sizeof (integer)); } types(D) %{ work = (double * )malloc(lwork * sizeof (double)); dgeesx_( &jvs, &psort, dselection_wrapper, &sens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(wr), $P(wi), $P(vs), &(integer){$PRIV(__p_size)}, $P(rconde), $P(rcondv), work, &lwork, iwork, &liwork, bwork, $P(info)); %} types(F) %{ work = (float * )malloc(lwork * sizeof (float)); sgeesx_( &jvs, &psort, fselection_wrapper, &sens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(sdim), $P(wr), $P(wi), $P(vs), &(integer){$PRIV(__p_size)}, $P(rconde), $P(rcondv), work, &lwork, iwork, &liwork, bwork, $P(info)); %} free(work); free(iwork); if ($sort()) free(bwork); ', Doc => ' =for ref Computes for an N-by-N real nonsymmetric matrix A, the eigenvalues, the real Schur form T, and, optionally, the matrix of Schur vectors Z. This gives the Schur factorization A = Z*T*Z\'. Optionally, it also orders the eigenvalues on the diagonal of the real Schur form so that selected eigenvalues are at the top left; computes a reciprocal condition number for the average of the selected eigenvalues (rconde); and computes a reciprocal condition number for the right invariant subspace corresponding to the selected eigenvalues (rcondv). The leading columns of Z form an orthonormal basis for this invariant subspace. For further explanation of the reciprocal condition numbers rconde and rcondv, see Section 4.10 of the LAPACK Users\' Guide (where these quantities are called s and sep respectively). A real matrix is in real Schur form if it is upper quasi-triangular with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the form [ a b ] [ c a ] where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). Arguments ========= jobvs: = 0: Schur vectors are not computed; = 1: Schur vectors are computed. sort: Specifies whether or not to order the eigenvalues on the diagonal of the Schur form. = 0: Eigenvalues are not ordered; = 1: Eigenvalues are ordered (see select_func). select_func: If sort = 1, select_func is used to select eigenvalues to sort to the top left of the Schur form else select_func is not referenced. An eigenvalue wr(j)+sqrt(-1)*wi(j) is selected if select_func(wr(j),wi(j)) is true; i.e., if either one of a complex conjugate pair of eigenvalues is selected, then both are. Note that a selected complex eigenvalue may no longer satisfy select_func(wr(j),wi(j)) = 1 after ordering, since ordering may change the value of complex eigenvalues (especially if the eigenvalue is ill-conditioned); in this case info may be set to N+3 (see info below). sense: Determines which reciprocal condition numbers are computed. = 0: None are computed; = 1: Computed for average of selected eigenvalues only; = 2: Computed for selected right invariant subspace only; = 3: Computed for both. If sense = 1, 2 or 3, sort must equal 1. A: On entry, the N-by-N matrix A. On exit, A is overwritten by its real Schur form T. sdim: If sort = 0, sdim = 0. If sort = 1, sdim = number of eigenvalues (after sorting) for which select_func is 1. (Complex conjugate pairs for which select_func is 1 for either eigenvalue count as 2.) wr: wi: wr and wi contain the real and imaginary parts, respectively, of the computed eigenvalues, in the same order that they appear on the diagonal of the output Schur form T. Complex conjugate pairs of eigenvalues appear consecutively with the eigenvalue having the positive imaginary part first. vs If jobvs = 1, vs contains the orthogonal matrix Z of Schur vectors else vs is not referenced. rconde: If sense = 1 or 3, rconde contains the reciprocal condition number for the average of the selected eigenvalues. Not referenced if sense = 0 or 2. rcondv: If sense = 2 or 3, rcondv contains the reciprocal condition number for the selected right invariant subspace. Not referenced if sense = 0 or 1. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: if info = i, and i is <= N: the QR algorithm failed to compute all the eigenvalues; elements 1:ilo-1 and i+1:N of wr and wi contain those eigenvalues which have converged; if jobvs = 1, vs contains the transformation which reduces A to its partially converged Schur form. = N+1: the eigenvalues could not be reordered because some eigenvalues were too close to separate (the problem is very ill-conditioned); = N+2: after reordering, roundoff changed values of some complex eigenvalues so that leading eigenvalues in the Schur form no longer satisfy select_func=1 This could also be caused by underflow due to scaling. =for example sub select_function{ my ($a, $b) = @_; # Stable "discrete time" eigenspace return sqrt($a**2 + $b**2) < 1 ? 1 : 0; } $A = random (5,5); $wr= zeroes(5); $wi = zeroes(5); $vs = zeroes(5,5); $sdim = null; $rconde = null; $rcondv = null; $info = null; geesx($A, 1,1, 3, $wr, $wi, $vs, $sdim, $rconde, $rcondv, $info, \&select_function); '); pp_addhdr(' static SV* fgselect_function; PDL_Long fgselection_wrapper(float *zr, float *zi, float *d) { dSP ; long choice; int retval; ENTER ; SAVETMPS ; PUSHMARK(sp) ; XPUSHs(sv_2mortal(newSVnv((double) *zr))); XPUSHs(sv_2mortal(newSVnv((double) *zi))); XPUSHs(sv_2mortal(newSVnv((double) *d))); PUTBACK ; retval = perl_call_sv(fgselect_function, G_SCALAR); SPAGAIN; if (retval != 1) croak("Error calling perl function\n"); choice = (long ) POPl ; /* Return value */ PUTBACK ; FREETMPS ; LEAVE ; return choice; } static SV* dgselect_function; PDL_Long dgselection_wrapper(double *zr, double *zi, double *d) { dSP ; long choice; int retval; ENTER ; SAVETMPS ; PUSHMARK(sp) ; XPUSHs(sv_2mortal(newSVnv(*zr))); XPUSHs(sv_2mortal(newSVnv(*zi))); XPUSHs(sv_2mortal(newSVnv(*d))); PUTBACK ; retval = perl_call_sv(dgselect_function, G_SCALAR); SPAGAIN; if (retval != 1) croak("Error calling perl function\n"); choice = (long ) POPl ; /* Return value */ PUTBACK ; FREETMPS ; LEAVE ; return choice; } '); pp_def("gges", HandleBad => 0, Pars => '[io,phys]A(n,n); int jobvsl();int jobvsr();int sort();[io,phys]B(n,n);[o,phys]alphar(n);[o,phys]alphai(n);[o,phys]beta(n);[o,phys]VSL(m,m);[o,phys]VSR(p,p);int [o,phys]sdim();int [o,phys]info()', OtherPars => "SV* select_func" , GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; char pjobvsl = \'N\', pjobvsr = \'N\', psort = \'N\'; integer *bwork; types(F) %{ extern int sgges_(char *jobvsl, char *jobvsr, char *sort, L_fp delctg, integer *n, float *a, integer *lda, float *b, integer *ldb, integer *sdim, float *alphar, float *alphai, float *beta, float *vsl, integer *ldvsl, float *vsr, integer *ldvsr, float *work, integer *lwork, logical *bwork, integer *info); float tmp_work; fgselect_function = $PRIV(select_func); %} types(D) %{ extern int dgges_(char *jobvsl, char *jobvsr, char *sort, L_fp delctg, integer *n, double *a, integer *lda, double *b, integer *ldb, integer *sdim, double *alphar, double *alphai, double *beta, double *vsl, integer *ldvsl, double *vsr, integer *ldvsr, double *work, integer *lwork, logical *bwork, integer *info); double tmp_work; dgselect_function = $PRIV(select_func); %} if ($jobvsl()) pjobvsl = \'V\'; if ($jobvsr()) pjobvsr = \'V\'; if ($sort()){ psort = \'S\'; bwork = (integer *)malloc($PRIV(__n_size) * sizeof(integer)); } types(F) %{ sgges_( &pjobvsl, &pjobvsr, &psort, fgselection_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alphar), $P(alphai), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, &tmp_work, &lwork, bwork, $P(info)); %} types(D) %{ dgges_( &pjobvsl, &pjobvsr, &psort, dgselection_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alphar), $P(alphai), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, &tmp_work, &lwork, bwork, $P(info)); %} lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} types(F) %{ sgges_( &pjobvsl, &pjobvsr, &psort, fgselection_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alphar), $P(alphai), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, work, &lwork, bwork, $P(info)); %} types(D) %{ dgges_( &pjobvsl, &pjobvsr, &psort, dgselection_wrapper, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alphar), $P(alphai), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, work, &lwork, bwork, $P(info)); %} free(work); } if ($sort()) free (bwork); ', Doc => ' =for ref Computes for a pair of N-by-N real nonsymmetric matrices (A,B), the generalized eigenvalues, the generalized real Schur form (S,T), optionally, the left and/or right matrices of Schur vectors (VSL and VSR). This gives the generalized Schur factorization (A,B) = ( (VSL)*S*(VSR)\', (VSL)*T*(VSR)\' ) Optionally, it also orders the eigenvalues so that a selected cluster of eigenvalues appears in the leading diagonal blocks of the upper quasi-triangular matrix S and the upper triangular matrix T.The leading columns of VSL and VSR then form an orthonormal basis for the corresponding left and right eigenspaces (deflating subspaces). (If only the generalized eigenvalues are needed, use the driver ggev instead, which is faster.) A generalized eigenvalue for a pair of matrices (A,B) is a scalar w or a ratio alpha/beta = w, such that A - w*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0 or both being zero. A pair of matrices (S,T) is in generalized real Schur form if T is upper triangular with non-negative diagonal and S is block upper triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond to real generalized eigenvalues, while 2-by-2 blocks of S will be "standardized" by making the corresponding elements of T have the form: [ a 0 ] [ 0 b ] and the pair of corresponding 2-by-2 blocks in S and T will have a complex conjugate pair of generalized eigenvalues. Arguments ========= jobvsl: = 0: do not compute the left Schur vectors; = 1: compute the left Schur vectors. jobvsr: = 0: do not compute the right Schur vectors; = 1: compute the right Schur vectors. sort: Specifies whether or not to order the eigenvalues on the diagonal of the generalized Schur form. = 0: Eigenvalues are not ordered; = 1: Eigenvalues are ordered (see delztg); delztg: If sort = 0, delztg is not referenced. If sort = 1, delztg is used to select eigenvalues to sort to the top left of the Schur form. An eigenvalue (alphar(j)+alphai(j))/beta(j) is selected if delztg(alphar(j),alphai(j),beta(j)) is true; i.e. if either one of a complex conjugate pair of eigenvalues is selected, then both complex eigenvalues are selected. Note that in the ill-conditioned case, a selected complex eigenvalue may no longer satisfy delztg(alphar(j),alphai(j), beta(j)) = 1 after ordering. info is to be set to N+2 in this case. A: On entry, the first of the pair of matrices. On exit, A has been overwritten by its generalized Schur form S. B: On entry, the second of the pair of matrices. On exit, B has been overwritten by its generalized Schur form T. sdim: If sort = 0, sdim = 0. If sort = 1, sdim = number of eigenvalues (after sorting) for which delztg is true. (Complex conjugate pairs for which delztg is true for either eigenvalue count as 2.) alphar: alphai: beta: On exit, (alphar(j) + alphai(j)*i)/beta(j), j=1,...,N, will be the generalized eigenvalues. alphar(j) + alphai(j)*i, and beta(j),j=1,...,N are the diagonals of the complex Schur form (S,T) that would result if the 2-by-2 diagonal blocks of the real Schur form of (A,B) were further reduced to triangular form using 2-by-2 complex unitary transformations. If alphai(j) is zero, then the j-th eigenvalue is real; if positive, then the j-th and (j+1)-st eigenvalues are a complex conjugate pair, with alphai(j+1) negative. Note: the quotients alphar(j)/beta(j) and alphai(j)/beta(j) may easily over- or underflow, and beta(j) may even be zero. Thus, the user should avoid naively computing the ratio. However, alphar and alphai will be always less than and usually comparable with norm(A) in magnitude, and beta always less than and usually comparable with norm(B). VSL: If jobvsl = 1, VSL will contain the left Schur vectors. Not referenced if jobvsl = 0. The leading dimension must always be >=1. VSR: If jobvsr = 1, VSR will contain the right Schur vectors. Not referenced if jobvsr = 0. The leading dimension must always be >=1. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. = 1,...,N: The QZ iteration failed. (A,B) are not in Schur form, but alphar(j), alphai(j), and beta(j) should be correct for j=info+1,...,N. > N: =N+1: other than QZ iteration failed in hgeqz. =N+2: after reordering, roundoff changed values of some complex eigenvalues so that leading eigenvalues in the Generalized Schur form no longer satisfy delztg=1 This could also be caused due to scaling. =N+3: reordering failed in tgsen. =for example sub my_select{ my ($zr, $zi, $d) = @_; # stable generalized eigenvalues for continuous time return ( ($zr < 0 && $d > 0 ) || ($zr > 0 && $d < 0) ) ? 1 : 0; } $a = random(5,5); $b = random(5,5); $sdim = null; $alphar = zeroes(5); $alphai = zeroes(5); $beta = zeroes(5); $vsl = zeroes(5,5); $vsr = zeroes(5,5); gges($a, 1, 1, 1, $b, $alphar, $alphai, $beta, $vsl, $vsr, $sdim,($info=null), \&my_select); '); pp_def("ggesx", HandleBad => 0, Pars => '[io,phys]A(n,n); int jobvsl();int jobvsr();int sort();int sense();[io,phys]B(n,n);[o,phys]alphar(n);[o,phys]alphai(n);[o,phys]beta(n);[o,phys]VSL(m,m);[o,phys]VSR(p,p);int [o,phys]sdim();[o,phys]rconde(q);[o,phys]rcondv(r);int [o,phys]info()', OtherPars => "SV* select_func" , GenericTypes => [F,D], Code => generate_code ' integer maxwrk, lwork,liwork; integer minwrk = 1; static integer c__0 = 0; static integer c__1 = 1; static integer c_n1 = -1; char pjobvsl = \'N\'; char pjobvsr = \'N\'; char psort = \'N\'; char psens = \'N\'; integer *bwork; integer *iwork; extern integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen opts_len); types(F) %{ extern int sggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp delctg, char *sense, integer *n, float *a, integer *lda, float *b, integer *ldb, integer *sdim, float *alphar, float *alphai, float *beta, float *vsl, integer *ldvsl, float *vsr, integer *ldvsr, float *rconde, float *rcondv, float *work, integer *lwork, integer *iwork, integer *liwork, logical *bwork, integer *info); fgselect_function = $PRIV(select_func); %} types(D) %{ extern int dggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp delctg, char *sense, integer *n, double *a, integer *lda, double *b, integer *ldb, integer *sdim, double *alphar, double *alphai, double *beta, double *vsl, integer *ldvsl, double *vsr, integer *ldvsr, double *rconde, double *rcondv, double *work, integer *lwork, integer *iwork, integer *liwork, logical *bwork, integer *info); dgselect_function = $PRIV(select_func); %} if ($jobvsr()) pjobvsr = \'V\'; if ($sort()){ psort = \'S\'; bwork = (integer *)malloc($PRIV(__n_size) * sizeof(integer)); } switch ($sense()) { case 1: psens = \'E\'; break; case 2: psens = \'V\'; break; case 3: psens = \'B\'; break; default: psens = \'N\'; } // Bug in Lapack ????? // if (!$sense()) // liwork = 1; // else // { liwork = $SIZE(n) + 6; iwork = (integer *)malloc(liwork * sizeof(integer)); // } // Code modified from Lapack // TODO other shur form above // The actual updated release (clapack 09/20/2000) do not allow // querying the workspace. See release notes of Lapack // for this feature. minwrk = ($SIZE(n) + 1 << 3) + 16; maxwrk = ($SIZE(n) + 1) * 7 + $SIZE(n) * (integer ) ilaenv_(&c__1, "DGEQRF", " ", &(integer){$PRIV(__n_size)}, &c__1, &(integer){$PRIV(__n_size)}, &c__0, (ftnlen)6, (ftnlen)1) + 16; if ($jobvsl()) { integer i__1 = maxwrk; integer i__2 = minwrk + $SIZE(n) * (integer )ilaenv_(&c__1, "DORGQR" , " ", &(integer){$PRIV(__n_size)}, &c__1, &(integer){$PRIV(__n_size)}, &c_n1, (ftnlen)6, (ftnlen)1); maxwrk = (integer ) max(i__1,i__2); pjobvsl = \'V\'; } lwork = (integer ) max(maxwrk,minwrk); { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); sggesx_( &pjobvsl, &pjobvsr, &psort, fgselection_wrapper, &psens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alphar), $P(alphai), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, $P(rconde), $P(rcondv), work, &lwork, iwork, &liwork, bwork, $P(info)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); dggesx_( &pjobvsl, &pjobvsr, &psort, dgselection_wrapper, &psens, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(sdim), $P(alphar), $P(alphai), $P(beta), $P(VSL), &(integer){$PRIV(__m_size)}, $P(VSR), &(integer){$PRIV(__p_size)}, $P(rconde), $P(rcondv), work, &lwork, iwork, &liwork, bwork, $P(info)); %} free(work); } if ($sort()) free(bwork); free(iwork); ', Doc => ' =for ref Computes for a pair of N-by-N real nonsymmetric matrices (A,B), the generalized eigenvalues, the real Schur form (S,T), and, optionally, the left and/or right matrices of Schur vectors (VSL and VSR). This gives the generalized Schur factorization (A,B) = ( (VSL) S (VSR)\', (VSL) T (VSR)\' ) Optionally, it also orders the eigenvalues so that a selected cluster of eigenvalues appears in the leading diagonal blocks of the upper quasi-triangular matrix S and the upper triangular matrix T; computes a reciprocal condition number for the average of the selected eigenvalues (RCONDE); and computes a reciprocal condition number for the right and left deflating subspaces corresponding to the selected eigenvalues (RCONDV). The leading columns of VSL and VSR then form an orthonormal basis for the corresponding left and right eigenspaces (deflating subspaces). A generalized eigenvalue for a pair of matrices (A,B) is a scalar w or a ratio alpha/beta = w, such that A - w*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0 or for both being zero. A pair of matrices (S,T) is in generalized real Schur form if T is upper triangular with non-negative diagonal and S is block upper triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond to real generalized eigenvalues, while 2-by-2 blocks of S will be "standardized" by making the corresponding elements of T have the form: [ a 0 ] [ 0 b ] and the pair of corresponding 2-by-2 blocks in S and T will have a complex conjugate pair of generalized eigenvalues. Further details =============== An approximate (asymptotic) bound on the average absolute error of the selected eigenvalues is EPS * norm((A, B)) / RCONDE( 1 ). An approximate (asymptotic) bound on the maximum angular error in the computed deflating subspaces is EPS * norm((A, B)) / RCONDV( 2 ). See LAPACK User\'s Guide, section 4.11 for more information. Arguments ========= jobvsl: = 0: do not compute the left Schur vectors; = 1: compute the left Schur vectors. jobvsr: = 0: do not compute the right Schur vectors; = 1: compute the right Schur vectors. sort: Specifies whether or not to order the eigenvalues on the diagonal of the generalized Schur form. = 0: Eigenvalues are not ordered; = 1: Eigenvalues are ordered (see delztg); delztg: If sort = 0, delztg is not referenced. If sort = 1, delztg is used to select eigenvalues to sort to the top left of the Schur form. An eigenvalue (alphar(j)+alphai(j))/beta(j) is selected if delztg(alphar(j),alphai(j),beta(j)) is true; i.e. if either one of a complex conjugate pair of eigenvalues is selected, then both complex eigenvalues are selected. Note that in the ill-conditioned case, a selected complex eigenvalue may no longer satisfy delztg(alphar(j),alphai(j), beta(j)) = 1 after ordering. info is to be set to N+2 in this case. sense: Determines which reciprocal condition numbers are computed. = 0 : None are computed; = 1 : Computed for average of selected eigenvalues only; = 2 : Computed for selected deflating subspaces only; = 3 : Computed for both. If sense = 1, 2, or 3, sort must equal 1. A: On entry, the first of the pair of matrices. On exit, A has been overwritten by its generalized Schur form S. B: On entry, the second of the pair of matrices. On exit, B has been overwritten by its generalized Schur form T. sdim: If sort = 0, sdim = 0. If sort = 1, sdim = number of eigenvalues (after sorting) for which delztg is true. (Complex conjugate pairs for which delztg is true for either eigenvalue count as 2.) alphar: alphai: beta: On exit, (alphar(j) + alphai(j)*i)/beta(j), j=1,...,N, will be the generalized eigenvalues. alphar(j) + alphai(j)*i, and beta(j),j=1,...,N are the diagonals of the complex Schur form (S,T) that would result if the 2-by-2 diagonal blocks of the real Schur form of (A,B) were further reduced to triangular form using 2-by-2 complex unitary transformations. If alphai(j) is zero, then the j-th eigenvalue is real; if positive, then the j-th and (j+1)-st eigenvalues are a complex conjugate pair, with alphai(j+1) negative. Note: the quotients alphar(j)/beta(j) and alphai(j)/beta(j) may easily over- or underflow, and beta(j) may even be zero. Thus, the user should avoid naively computing the ratio. However, alphar and alphai will be always less than and usually comparable with norm(A) in magnitude, and beta always less than and usually comparable with norm(B). VSL: If jobvsl = 1, VSL will contain the left Schur vectors. Not referenced if jobvsl = 0. The leading dimension must always be >=1. VSR: If jobvsr = 1, VSR will contain the right Schur vectors. Not referenced if jobvsr = 0. The leading dimension must always be >=1. rconde: If sense = 1 or 3, rconde(1) and rconde(2) contain the reciprocal condition numbers for the average of the selected eigenvalues. Not referenced if sense = 0 or 2. rcondv: If sense = 2 or 3, rcondv(1) and rcondv(2) contain the reciprocal condition numbers for the selected deflating subspaces. Not referenced if sense = 0 or 1. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. = 1,...,N: The QZ iteration failed. (A,B) are not in Schur form, but alphar(j), alphai(j), and beta(j) should be correct for j=info+1,...,N. > N: =N+1: other than QZ iteration failed in hgeqz. =N+2: after reordering, roundoff changed values of some complex eigenvalues so that leading eigenvalues in the Generalized Schur form no longer satisfy delztg=1 This could also be caused due to scaling. =N+3: reordering failed in tgsen. =for example sub my_select{ my ($zr, $zi, $d) = @_; # Eigenvalue : (ZR/D) + sqrt(-1)*(ZI/D) # stable generalized eigenvalues for discrete time return (sqrt($zr**2 + $zi**2) < abs($d) ) ? 1 : 0; } $a = random(5,5); $b = random(5,5); $sdim = null; $alphar = zeroes(5); $alphai = zeroes(5); $beta = zeroes(5); $vsl = zeroes(5,5); $vsr = zeroes(5,5); $rconde = zeroes(2); $rcondv = zeroes(2); ggesx($a, 1, 1, 1, 3,$b, $alphar, $alphai, $beta, $vsl, $vsr, $sdim, $rconde, $rcondv, ($info=null), \&my_select); '); pp_def("syev", HandleBad => 0, Pars => '[io,phys]A(n,n); int jobz(); int uplo(); [o,phys]w(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int ssyev_(char *jobz, char *uplo, integer *n, float *a, integer *lda, float *w, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dsyev_(char *jobz, char *uplo, integer *n, double *a, integer *lda, double *w, double *work, integer *lwork, integer *info); double tmp_work; %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; $TFD(ssyev_,dsyev_)( &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(ssyev_,dsyev_)( &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes all eigenvalues and, optionally, eigenvectors of a real symmetric matrix A. Arguments ========= jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. uplo = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, if jobz = 1, then if info = 0, A contains the orthonormal eigenvectors of the matrix A. If jobz = 0, then on exit the lower triangle (if uplo=1) or the upper triangle (if uplo=0) of A, including the diagonal, is destroyed. w: If info = 0, the eigenvalues in ascending order. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the algorithm failed to converge; i off-diagonal elements of an intermediate tridiagonal form did not converge to zero. =for example # Assume $a is symmetric ;) $a = random (5,5); syev($a, 1,1, (my $w = zeroes(5)), (my $info=null)); '); pp_def("syevd", HandleBad => 0, Pars => '[io,phys]A(n,n); int jobz(); int uplo(); [o,phys]w(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; integer lwork = -1; integer liwork = -1; integer tmp_liwork; integer *iwork; types(F) %{ extern int ssyevd_(char *jobz, char *uplo, integer *n, float *a, integer *lda, float *w, float *work, integer *lwork, integer *iwork, integer *liwork, integer *info); float tmp_work; %} types(D) %{ extern int dsyevd_(char *jobz, char *uplo, integer *n, double *a, integer *lda, double *w, double *work, integer *lwork, integer *iwork, integer *liwork, integer *info); double tmp_work; %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; $TFD(ssyevd_,dsyevd_)( &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), &tmp_work, &lwork, &tmp_liwork, &liwork, $P(info)); lwork = (integer )tmp_work; liwork = (integer )tmp_liwork; iwork = (integer *)malloc(liwork * sizeof(integer)); { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(ssyevd_,dsyevd_)( &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(w), work, &lwork, iwork, &liwork, $P(info)); free(work); free(iwork); } ', Doc => ' =for ref Computes all eigenvalues and, optionally, eigenvectors of a real symmetric matrix A. If eigenvectors are desired, it uses a divide and conquer algorithm. The divide and conquer algorithm makes very mild assumptions about floating point arithmetic. It will work on machines with a guard digit in add/subtract, or on those binary machines without guard digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. It could conceivably fail on hexadecimal or decimal machines without guard digits, but we know of none. Because of large use of BLAS of level 3, syevd needs N**2 more workspace than syevx. Arguments ========= jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. uplo = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, if jobz = 1, then if info = 0, A contains the orthonormal eigenvectors of the matrix A. If jobz = 0, then on exit the lower triangle (if uplo=1) or the upper triangle (if uplo=0) of A, including the diagonal, is destroyed. w: If info = 0, the eigenvalues in ascending order. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the algorithm failed to converge; i off-diagonal elements of an intermediate tridiagonal form did not converge to zero. =for example # Assume $a is symmetric ;) $a = random (5,5); syevd($a, 1,1, (my $w = zeroes(5)), (my $info=null)); '); pp_def("syevx", HandleBad => 0, Pars => '[phys]A(n,n); int jobz(); int range(); int uplo(); [phys]vl(); [phys]vu(); int [phys]il(); int [phys]iu(); [phys]abstol(); int [o,phys]m(); [o,phys]w(n); [o,phys]z(p,q);int [o,phys]ifail(r); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; char prange = \'A\'; integer lwork = -1; integer *iwork; types(F) %{ extern int ssyevx_(char *jobz, char *range, char *uplo, integer *n, float *a, integer *lda, float *vl, float *vu, integer * il, integer *iu, float *abstol, integer *m, float *w, float *z__, integer *ldz, float *work, integer *lwork, integer *iwork, integer *ifail, integer *info); float tmp_work; %} types(D) %{ extern int dsyevx_(char *jobz, char *range, char *uplo, integer *n, double *a, integer *lda, double *vl, double *vu, integer * il, integer *iu, double *abstol, integer *m, double *w, double *z__, integer *ldz, double *work, integer *lwork, integer *iwork, integer *ifail, integer *info); double tmp_work; %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; switch ($range()) { case 1: prange = \'V\'; break; case 2: prange = \'I\'; break; default: prange = \'A\'; } iwork = (integer *)malloc(5 * $SIZE (n) * sizeof(integer)); $TFD(ssyevx_,dsyevx_)( &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(z), &(integer){$PRIV(__p_size)}, &tmp_work, &lwork, iwork, $P(ifail), $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(ssyevx_,dsyevx_)( &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(z), &(integer){$PRIV(__p_size)}, work, &lwork, iwork, $P(ifail), $P(info)); free(work); free(iwork); } ', Doc => ' =for ref Computes selected eigenvalues and, optionally, eigenvectors of a real symmetric matrix A. Eigenvalues and eigenvectors can be selected by specifying either a range of values or a range of indices for the desired eigenvalues. Arguments ========= jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. range: = 0: all eigenvalues will be found. = 1: all eigenvalues in the half-open interval (vl,vu] will be found. = 1: the il-th through iu-th eigenvalues will be found. uplo = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, the lower triangle (if uplo=1) or the upper triangle (if uplo=0) of A, including the diagonal, is destroyed. vl: vu: If range=1, the lower and upper bounds of the interval to be searched for eigenvalues. vl < vu. Not referenced if range = 0 or 2. il: iu: If range=2, the indices (in ascending order) of the smallest and largest eigenvalues to be returned. 1 <= il <= iu <= N, if N > 0; il = 1 and iu = 0 if N = 0. Not referenced if range = 0 or 1. abstol: The absolute error tolerance for the eigenvalues. An approximate eigenvalue is accepted as converged when it is determined to lie in an interval [a,b] of width less than or equal to abstol + EPS * max( |a|,|b| ) , where EPS is the machine precision. If abstol is less than or equal to zero, then EPS*|T| will be used in its place, where |T| is the 1-norm of the tridiagonal matrix obtained by reducing A to tridiagonal form. Eigenvalues will be computed most accurately when abstol is set to twice the underflow threshold 2*lamch(1), not zero. If this routine returns with info>0, indicating that some eigenvectors did not converge, try setting abstol to 2*lamch(1). See "Computing Small Singular Values of Bidiagonal Matrices with Guaranteed High Relative Accuracy," by Demmel and Kahan, LAPACK Working Note #3. m: The total number of eigenvalues found. 0 <= m <= N. If range = 0, m = N, and if range = 2, m = iu-il+1. w: On normal exit, the first M elements contain the selected eigenvalues in ascending order. z: If jobz = 1, then if info = 0, the first m columns of z contain the orthonormal eigenvectors of the matrix A corresponding to the selected eigenvalues, with the i-th column of z holding the eigenvector associated with w(i). If an eigenvector fails to converge, then that column of z contains the latest approximation to the eigenvector, and the index of the eigenvector is returned in ifail. If jobz = 0, then z is not referenced. Note: the user must ensure that at least max(1,m) columns are supplied in the array z; if range = 1, the exact value of m is not known in advance and an upper bound must be used. ifail: If jobz = 1, then if info = 0, the first m elements of ifail are zero. If info > 0, then ifail contains the indices of the eigenvectors that failed to converge. If jobz = 0, then ifail is not referenced. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, then i eigenvectors failed to converge. Their indices are stored in array ifail. =for example # Assume $a is symmetric ;) $a = random (5,5); $unfl = lamch(1); $ovfl = lamch(9); labad($unfl, $ovfl); $abstol = $unfl + $unfl; $m = null; $info = null; $ifail = zeroes(5); $w = zeroes(5); $z = zeroes(5,5); syevx($a, 1,0,1,0,0,0,0,$abstol, $m, $w, $z ,$ifail, $info); '); pp_def("syevr", HandleBad => 0, Pars => '[phys]A(n,n); int jobz(); int range(); int uplo(); [phys]vl(); [phys]vu(); int [phys]il(); int [phys]iu();[phys]abstol();int [o,phys]m();[o,phys]w(n); [o,phys]z(p,q);int [o,phys]isuppz(r); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; char prange = \'A\'; integer lwork = -1; integer liwork = -1; integer *iwork; integer tmp_iwork; types(F) %{ extern int ssyevr_(char *jobz, char *range, char *uplo, integer *n, float *a, integer *lda, float *vl, float *vu, integer * il, integer *iu, float *abstol, integer *m, float *w, float *z__, integer *ldz, integer *isuppz, float *work, integer *lwork, integer *iwork, integer *liwork, integer *info); float tmp_work; %} types(D) %{ extern int dsyevr_(char *jobz, char *range, char *uplo, integer *n, double *a, integer *lda, double *vl, double *vu, integer * il, integer *iu, double *abstol, integer *m, double *w, double *z__, integer *ldz, integer *isuppz, double *work, integer *lwork, integer *iwork, integer *liwork, integer *info); double tmp_work; %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; switch ($range()) { case 1: prange = \'V\'; break; case 2: prange = \'I\'; break; default: prange = \'A\'; } $TFD(ssyevr_,dsyevr_)( &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(z), &(integer){$PRIV(__p_size)}, $P(isuppz), &tmp_work, &lwork, &tmp_iwork, &liwork, $P(info)); lwork = (integer )tmp_work; liwork = (integer )tmp_iwork; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} iwork = (integer *)malloc(liwork * sizeof(integer)); $TFD(ssyevr_,dsyevr_)( &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(z), &(integer){$PRIV(__p_size)}, $P(isuppz), work, &lwork, iwork, &liwork, $P(info)); free(work); free(iwork); } ', Doc => ' =for ref Computes selected eigenvalues and, optionally, eigenvectors of a real symmetric matrix T. Eigenvalues and eigenvectors can be selected by specifying either a range of values or a range of indices for the desired eigenvalues. Whenever possible, syevr calls stegr to compute the eigenspectrum using Relatively Robust Representations. stegr computes eigenvalues by the dqds algorithm, while orthogonal eigenvectors are computed from various "good" L D L^T representations (also known as Relatively Robust Representations). Gram-Schmidt orthogonalization is avoided as far as possible. More specifically, the various steps of the algorithm are as follows. For the i-th unreduced block of T, (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T is a relatively robust representation, (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high relative accuracy by the dqds algorithm, (c) If there is a cluster of close eigenvalues, "choose" sigma_i close to the cluster, and go to step (a), (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, compute the corresponding eigenvector by forming a rank-revealing twisted factorization. The desired accuracy of the output can be specified by the input parameter abstol. For more details, see "A new O(n^2) algorithm for the symmetric tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, Computer Science Division Technical Report No. UCB//CSD-97-971, UC Berkeley, May 1997. Note 1 : syevr calls stegr when the full spectrum is requested on machines which conform to the ieee-754 floating point standard. syevr calls stebz and stein on non-ieee machines and when partial spectrum requests are made. Normal execution of stegr may create NaNs and infinities and hence may abort due to a floating point exception in environments which do not handle NaNs and infinities in the ieee standard default manner. Arguments ========= jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. range: = 0: all eigenvalues will be found. = 1: all eigenvalues in the half-open interval (vl,vu] will be found. = 2: the il-th through iu-th eigenvalues will be found. ********* For range = 1 or 2 and iu - il < N - 1, stebz and ********* stein are called uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, the lower triangle (if uplo=1) or the upper triangle (if uplo=0) of A, including the diagonal, is destroyed. vl: vu: If range=1, the lower and upper bounds of the interval to be searched for eigenvalues. vl < vu. Not referenced if range = 0 or 2. il: iu: If range=2, the indices (in ascending order) of the smallest and largest eigenvalues to be returned. 1 <= il <= iu <= N, if N > 0; il = 1 and iu = 0 if N = 0. Not referenced if range = 0 or 1. abstol: The absolute error tolerance for the eigenvalues. An approximate eigenvalue is accepted as converged when it is determined to lie in an interval [a,b] of width less than or equal to abstol + EPS * max( |a|,|b| ) , where EPS is the machine precision. If abstol is less than or equal to zero, then EPS*|T| will be used in its place, where |T| is the 1-norm of the tridiagonal matrix obtained by reducing A to tridiagonal form. See "Computing Small Singular Values of Bidiagonal Matrices with Guaranteed High Relative Accuracy," by Demmel and Kahan, LAPACK Working Note #3. If high relative accuracy is important, set abstol to lamch(1). Doing so will guarantee that eigenvalues are computed to high relative accuracy when possible in future releases. The current code does not make any guarantees about high relative accuracy, but furure releases will. See J. Barlow and J. Demmel, "Computing Accurate Eigensystems of Scaled Diagonally Dominant Matrices", LAPACK Working Note #7, for a discussion of which matrices define their eigenvalues to high relative accuracy. m: The total number of eigenvalues found. 0 <= m <= N. If range = 0, m = N, and if range = 2, m = iu-il+1. w: The first m elements contain the selected eigenvalues in ascending order. z: If jobz = 1, then if info = 0, the first m columns of z contain the orthonormal eigenvectors of the matrix A corresponding to the selected eigenvalues, with the i-th column of z holding the eigenvector associated with w(i). If jobz = 0, then z is not referenced. Note: the user must ensure that at least max(1,m) columns are supplied in the array z; if range = 1, the exact value of m is not known in advance and an upper bound must be used. isuppz: array of int, dimension ( 2*max(1,m) ) The support of the eigenvectors in z, i.e., the indices indicating the nonzero elements in z. The i-th eigenvector is nonzero only in elements isuppz( 2*i-1 ) through isuppz( 2*i ). ********* Implemented only for range = 0 or 2 and iu - il = N - 1 info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: Internal error =for example # Assume $a is symmetric ;) $a = random (5,5); $unfl = lamch(1); $ovfl = lamch(9); labad($unfl, $ovfl); $abstol = $unfl + $unfl; $m = null; $info = null; $isuppz = zeroes(10); $w = zeroes(5); $z = zeroes(5,5); syevr($a, 1,0,1,0,0,0,0,$abstol, $m, $w, $z ,$isuppz, $info); '); pp_def("sygv", HandleBad => 0, Pars => '[io,phys]A(n,n);int [phys]itype();int jobz(); int uplo();[io,phys]B(n,n);[o,phys]w(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int ssygv_(integer *itype, char *jobz, char *uplo, integer * n, float *a, integer *lda, float *b, integer *ldb, float *w, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dsygv_(integer *itype, char *jobz, char *uplo, integer * n, double *a, integer *lda, double *b, integer *ldb, double *w, double *work, integer *lwork, integer *info); double tmp_work; %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; $TFD(ssygv_,dsygv_)( $P(itype), &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(w), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(ssygv_,dsygv_)( $P(itype), &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(w), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes all the eigenvalues, and optionally, the eigenvectors of a real generalized symmetric-definite eigenproblem, of the form A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and B are assumed to be symmetric and B is also positive definite. Arguments ========= itype: Specifies the problem type to be solved: = 1: A*x = (lambda)*B*x = 2: A*B*x = (lambda)*x = 3: B*A*x = (lambda)*x jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. uplo: = 0: Upper triangles of A and B are stored; = 1: Lower triangles of A and B are stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, if jobz = 1, then if info = 0, A contains the matrix Z of eigenvectors. The eigenvectors are normalized as follows: if itype = 1 or 2, Z\'*B*Z = I; if itype = 3, Z\'*inv(B)*Z = I. If jobz = 0, then on exit the upper triangle (if uplo=0) or the lower triangle (if uplo=1) of A, including the diagonal, is destroyed. B: On entry, the symmetric positive definite matrix B. If uplo = 0, the leading N-by-N upper triangular part of B contains the upper triangular part of the matrix B. If uplo = 1, the leading N-by-N lower triangular part of B contains the lower triangular part of the matrix B. On exit, if info <= N, the part of B containing the matrix is overwritten by the triangular factor U or L from the Cholesky factorization B = U\'*U or B = L*L\'. W: If info = 0, the eigenvalues in ascending order. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: potrf or syev returned an error code: <= N: if info = i, syev failed to converge; i off-diagonal elements of an intermediate tridiagonal form did not converge to zero; > N: if info = N + i, for 1 <= i <= N, then the leading minor of order i of B is not positive definite. The factorization of B could not be completed and no eigenvalues or eigenvectors were computed. =for example # Assume $a is symmetric ;) $a = random (5,5); # Assume $a is symmetric and positive definite ;) $b = random (5,5); sygv($a, 1,1, 0, $b, (my $w = zeroes(5)), (my $info=null)); '); pp_def("sygvd", HandleBad => 0, Pars => '[io,phys]A(n,n);int [phys]itype();int jobz(); int uplo();[io,phys]B(n,n);[o,phys]w(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; integer lwork = -1; integer liwork = -1; integer *iwork; integer tmp_iwork; types(F) %{ extern int ssygvd_(integer *itype, char *jobz, char *uplo, integer * n, float *a, integer *lda, float *b, integer *ldb, float *w, float *work, integer *lwork, integer *iwork, integer *liwork, integer *info); float tmp_work; %} types(D) %{ extern int dsygvd_(integer *itype, char *jobz, char *uplo, integer * n, double *a, integer *lda, double *b, integer *ldb, double *w, double *work, integer *lwork, integer *iwork, integer *liwork, integer *info); double tmp_work; %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; $TFD(ssygvd_,dsygvd_)( $P(itype), &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(w), &tmp_work, &lwork, &tmp_iwork, &liwork, $P(info)); lwork = (integer )tmp_work; liwork = (integer )tmp_iwork; iwork = (integer *)malloc(liwork * sizeof(integer)); { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(ssygvd_,dsygvd_)( $P(itype), &jz, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(w), work, &lwork, iwork, &liwork, $P(info)); free(work); } free(iwork); ', Doc => ' =for ref Computes all the eigenvalues, and optionally, the eigenvectors of a real generalized symmetric-definite eigenproblem, of the form A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and B are assumed to be symmetric and B is also positive definite. The divide and conquer algorithm makes very mild assumptions about floating point arithmetic. It will work on machines with a guard digit in add/subtract, or on those binary machines without guard digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. It could conceivably fail on hexadecimal or decimal machines without guard digits, but we know of none. Arguments ========= itype: Specifies the problem type to be solved: = 1: A*x = (lambda)*B*x = 2: A*B*x = (lambda)*x = 3: B*A*x = (lambda)*x jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. uplo: = 0: Upper triangles of A and B are stored; = 1: Lower triangles of A and B are stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, if jobz = 1, then if info = 0, A contains the matrix Z of eigenvectors. The eigenvectors are normalized as follows: if itype = 1 or 2, Z\'*B*Z = I; if itype = 3, Z\'*inv(B)*Z = I. If jobz = 0, then on exit the upper triangle (if uplo=0) or the lower triangle (if uplo=1) of A, including the diagonal, is destroyed. B: On entry, the symmetric positive definite matrix B. If uplo = 0, the leading N-by-N upper triangular part of B contains the upper triangular part of the matrix B. If uplo = 1, the leading N-by-N lower triangular part of B contains the lower triangular part of the matrix B. On exit, if info <= N, the part of B containing the matrix is overwritten by the triangular factor U or L from the Cholesky factorization B = U\'*U or B = L*L\'. W: If info = 0, the eigenvalues in ascending order. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: potrf or syev returned an error code: <= N: if info = i, syevd failed to converge; i off-diagonal elements of an intermediate tridiagonal form did not converge to zero; > N: if info = N + i, for 1 <= i <= N, then the leading minor of order i of B is not positive definite. The factorization of B could not be completed and no eigenvalues or eigenvectors were computed. =for example # Assume $a is symmetric ;) $a = random (5,5); # Assume $b is symmetric positive definite ;) $b = random (5,5); sygvd($a, 1,1, 0, $b, (my $w = zeroes(5)), (my $info=null)); '); pp_def("sygvx", HandleBad => 0, Pars => '[io,phys]A(n,n);int [phys]itype();int jobz();int range(); int uplo();[io,phys]B(n,n);[phys]vl();[phys]vu();int [phys]il();int [phys]iu();[phys]abstol();int [o,phys]m();[o,phys]w(n); [o,phys]Z(p,q);int [o,phys]ifail(r);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char jz = \'N\'; char puplo = \'U\'; char prange; integer lwork = -1; integer *iwork; types(F) %{ extern int ssygvx_(integer *itype, char *jobz, char *range, char * uplo, integer *n, float *a, integer *lda, float *b, integer *ldb, float *vl, float *vu, integer *il, integer *iu, float *abstol, integer *m, float *w, float *z__, integer *ldz, float *work, integer *lwork, integer *iwork, integer *ifail, integer *info); float tmp_work; %} types(D) %{ extern int dsygvx_(integer *itype, char *jobz, char *range, char * uplo, integer *n, double *a, integer *lda, double *b, integer *ldb, double *vl, double *vu, integer *il, integer *iu, double *abstol, integer *m, double *w, double *z__, integer *ldz, double *work, integer *lwork, integer *iwork, integer *ifail, integer *info); double tmp_work; %} if ($jobz()) jz = \'V\'; if ($uplo()) puplo = \'L\'; switch ($range()) { case 1: prange = \'V\'; break; case 2: prange = \'I\'; break; default: prange = \'A\'; } iwork = (integer *)malloc((5 * $SIZE(n)) * sizeof(integer)); $TFD(ssygvx_,dsygvx_)( $P(itype), &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(Z), &(integer){$PRIV(__p_size)}, &tmp_work, &lwork, iwork, $P(ifail), $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(ssygvx_,dsygvx_)( $P(itype), &jz, &prange, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(vl), $P(vu), $P(il), $P(iu), $P(abstol), $P(m), $P(w), $P(Z), &(integer){$PRIV(__p_size)}, work, &lwork, iwork, $P(ifail), $P(info)); free(work); } free(iwork); ', Doc => ' =for ref Computes selected eigenvalues, and optionally, eigenvectors of a real generalized symmetric-definite eigenproblem, of the form A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and B are assumed to be symmetric and B is also positive definite. Eigenvalues and eigenvectors can be selected by specifying either a range of values or a range of indices for the desired eigenvalues. Arguments ========= itype: Specifies the problem type to be solved: = 1: A*x = (lambda)*B*x = 2: A*B*x = (lambda)*x = 3: B*A*x = (lambda)*x jobz: = 0: Compute eigenvalues only; = 1: Compute eigenvalues and eigenvectors. range: = 0: all eigenvalues will be found. = 1: all eigenvalues in the half-open interval (vl,vu] will be found. = 2: the il-th through iu-th eigenvalues will be found. uplo: = 0: Upper triangle of A and B are stored; = 1: Lower triangle of A and B are stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A. On exit, the lower triangle (if uplo=1) or the upper triangle (if uplo=0) of A, including the diagonal, is destroyed. B: On entry, the symmetric matrix B. If uplo = 0, the leading N-by-N upper triangular part of B contains the upper triangular part of the matrix B. If uplo = 1, the leading N-by-N lower triangular part of B contains the lower triangular part of the matrix B. On exit, if info <= N, the part of B containing the matrix is overwritten by the triangular factor U or L from the Cholesky factorization B = U\'*U or B = L*L\'. vl: vu: If range=1, the lower and upper bounds of the interval to be searched for eigenvalues. vl < vu. Not referenced if range = 0 or 2. il: iu: If range=2, the indices (in ascending order) of the smallest and largest eigenvalues to be returned. 1 <= il <= iu <= N, if N > 0; il = 1 and iu = 0 if N = 0. Not referenced if range = 0 or 1. abstol: The absolute error tolerance for the eigenvalues. An approximate eigenvalue is accepted as converged when it is determined to lie in an interval [a,b] of width less than or equal to abstol + EPS * max( |a|,|b| ) , where EPS is the machine precision. If abstol is less than or equal to zero, then EPS*|T| will be used in its place, where |T| is the 1-norm of the tridiagonal matrix obtained by reducing A to tridiagonal form. Eigenvalues will be computed most accurately when abstol is set to twice the underflow threshold 2*lamch(1), not zero. If this routine returns with info>0, indicating that some eigenvectors did not converge, try setting abstol to 2* lamch(1). m: The total number of eigenvalues found. 0 <= m <= N. If range = 0, m = N, and if range = 2, m = iu-il+1. w: On normal exit, the first m elements contain the selected eigenvalues in ascending order. Z: If jobz = 0, then Z is not referenced. If jobz = 1, then if info = 0, the first m columns of Z contain the orthonormal eigenvectors of the matrix A corresponding to the selected eigenvalues, with the i-th column of Z holding the eigenvector associated with w(i). The eigenvectors are normalized as follows: if itype = 1 or 2, Z\'*B*Z = I; if itype = 3, Z\'*inv(B)*Z = I. If an eigenvector fails to converge, then that column of Z contains the latest approximation to the eigenvector, and the index of the eigenvector is returned in ifail. Note: the user must ensure that at least max(1,m) columns are supplied in the array Z; if range = 1, the exact value of m is not known in advance and an upper bound must be used. ifail: If jobz = 1, then if info = 0, the first M elements of ifail are zero. If info > 0, then ifail contains the indices of the eigenvectors that failed to converge. If jobz = 0, then ifail is not referenced. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: potrf or syevx returned an error code: <= N: if info = i, syevx failed to converge; i eigenvectors failed to converge. Their indices are stored in array ifail. > N: if info = N + i, for 1 <= i <= N, then the leading minor of order i of B is not positive definite. The factorization of B could not be completed and no eigenvalues or eigenvectors were computed. =for example # Assume $a is symmetric ;) $a = random (5,5); # Assume $b is symmetric positive definite ;) $b = random (5,5); $unfl = lamch(1); $ovfl = lamch(9); labad($unfl, $ovfl); $abstol = $unfl + $unfl; $m = null; $w=zeroes(5); $z = zeroes(5,5); $ifail = zeroes(5); sygvx($a, 1,1, 0,0, $b, 0, 0, 0, 0, $abstol, $m, $w, $z,$ifail,(my $info=null)); '); pp_def("gesv", HandleBad => 0, Pars => '[io,phys]A(n,n); [io,phys]B(n,m); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' types(F) %{ extern int sgesv_(integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer *ldb, integer *info); %} types(D) %{ extern int dgesv_(integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer *ldb, integer *info); %} $TFD(sgesv_,dgesv_)( &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Computes the solution to a real system of linear equations A * X = B, where A is an N-by-N matrix and X and B are N-by-NRHS matrices. The LU decomposition with partial pivoting and row interchanges is used to factor A as A = P * L * U, where P is a permutation matrix, L is unit lower triangular, and U is upper triangular. The factored form of A is then used to solve the system of equations A * X = B. Arguments ========= A: On entry, the N-by-N coefficient matrix A. On exit, the factors L and U from the factorization A = P*L*U; the unit diagonal elements of L are not stored. ipiv: The pivot indices that define the permutation matrix P; row i of the matrix was interchanged with row ipiv(i). B: On entry, the N-by-NRHS matrix of right hand side matrix B. On exit, if info = 0, the N-by-NRHS solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, U(i,i) is exactly zero. The factorization has been completed, but the factor U is exactly singular, so the solution could not be computed. =for example $a = random (5,5); $a = transpose($a); $b = random (5,5); $b = transpose($b); gesv($a,$b, (my $ipiv=zeroes(5)),(my $info=null)); print "The solution matrix X is :". transpose($b)."\n" unless $info; '); pp_def("gesvx", HandleBad => 0, Pars => '[io,phys]A(n,n); int trans(); int fact(); [io,phys]B(n,m); [io,phys]af(n,n); int [io,phys]ipiv(n); int [io]equed(); [io,phys]r(n); [io,phys]c(n); [o,phys]X(n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m);[o,phys]rpvgrw();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans, pfact, pequed; integer *iwork; types(F) %{ extern int sgesvx_(char *fact, char *trans, integer *n, integer * nrhs, float *a, integer *lda, float *af, integer *ldaf, integer *ipiv, char *equed, float *r__, float *c__, float *b, integer *ldb, float *x, integer *ldx, float * rcond, float *ferr, float *berr, float *work, integer * iwork, integer *info); float *work; %} types(D) %{ extern int dgesvx_(char *fact, char *trans, integer *n, integer * nrhs, double *a, integer *lda, double *af, integer *ldaf, integer *ipiv, char *equed, double *r__, double *c__, double *b, integer *ldb, double *x, integer *ldx, double * rcond, double *ferr, double *berr, double *work, integer * iwork, integer *info); double *work; %} switch ($trans()) { case 1: ptrans = \'T\'; break; case 2: ptrans = \'C\'; break; default: ptrans = \'N\'; } switch ($fact()) { case 1: pfact = \'N\'; break; case 2: pfact = \'E\'; break; default: pfact = \'F\'; } switch ($equed()) { case 1: pequed = \'R\'; break; case 2: pequed = \'C\'; break; case 3: pequed = \'B\'; break; default: pequed = \'N\'; } types(F) %{ work = (float *) malloc(4 * $PRIV(__n_size) * sizeof(float)); %} types(D) %{ work = (double *) malloc(4 * $PRIV(__n_size) * sizeof(double)); %} iwork = (integer *) malloc ($PRIV(__n_size)* sizeof (integer)); $TFD(sgesvx_,dgesvx_)( &pfact, &ptrans, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(af), &(integer){$PRIV(__n_size)}, $P(ipiv), &pequed, $P(r), $P(c), $P(B), &(integer){$PRIV(__n_size)}, $P(X), &(integer){$PRIV(__n_size)}, $P(rcond), $P(ferr), $P(berr), work, iwork, $P(info)); free(work); free(iwork); switch (pequed) { case \'R\': $equed() = 1; break; case \'C\': $equed() = 2; break; case \'B\': $equed() = 3; break; default: $equed()= 0; } $rpvgrw()=work[0]; ', Doc => ' =for ref Uses the LU factorization to compute the solution to a real system of linear equations A * X = B, where A is an N-by-N matrix and X and B are N-by-NRHS matrices. Error bounds on the solution and a condition estimate are also provided. =for desc The following steps are performed: =over 3 =item 1 If fact = 2, real scaling factors are computed to equilibrate the system: trans = 0: diag(r)*A*diag(c) *inv(diag(c))*X = diag(c)*B trans = 1: (diag(r)*A*diag(c))\' *inv(diag(r))*X = diag(c)*B trans = 2: (diag(r)*A*diag(c))**H *inv(diag(r))*X = diag(c)*B Whether or not the system will be equilibrated depends on the scaling of the matrix A, but if equilibration is used, A is overwritten by diag(r)*A*diag(c) and B by diag(r)*B (if trans=0) or diag(c)*B (if trans = 1 or 2). =item 2 If fact = 1 or 2, the LU decomposition is used to factor the matrix A (after equilibration if fact = 2) as A = P * L * U, where P is a permutation matrix, L is a unit lower triangular matrix, and U is upper triangular. =item 3 If some U(i,i)=0, so that U is exactly singular, then the routine returns with info = i. Otherwise, the factored form of A is used to estimate the condition number of the matrix A. If the reciprocal of the condition number is less than machine precision, info = N+1 is returned as a warning, but the routine still goes on to solve for X and compute error bounds as described below. =item 4 The system of equations is solved for X using the factored form of A. =item 5 Iterative refinement is applied to improve the computed solution matrix and calculate error bounds and backward error estimates for it. =item 6 If equilibration was used, the matrix X is premultiplied by diag(c) (if trans = 0) or diag(r) (if trans = 1 or 2) so that it solves the original system before equilibration. =back Arguments ========= fact: Specifies whether or not the factored form of the matrix A is supplied on entry, and if not, whether the matrix A should be equilibrated before it is factored. = 0: On entry, af and ipiv contain the factored form of A. If equed is not 0, the matrix A has been equilibrated with scaling factors given by r and c. A, af, and ipiv are not modified. = 1: The matrix A will be copied to af and factored. = 2: The matrix A will be equilibrated if necessary, then copied to af and factored. trans: Specifies the form of the system of equations: = 0: A * X = B (No transpose) = 1: A\' * X = B (Transpose) = 2: A**H * X = B (Transpose) A: On entry, the N-by-N matrix A. If fact = 0 and equed is not 0, then A must have been equilibrated by the scaling factors in r and/or c. A is not modified if fact = 0 or 1, or if fact = 2 and equed = 0 on exit. On exit, if equed != 0, A is scaled as follows: equed = 1: A := diag(r) * A equed = 2: A := A * diag(c) equed = 3: A := diag(r) * A * diag(c). af: If fact = 0, then af is an input argument and on entry contains the factors L and U from the factorization A = P*L*U as computed by getrf. If equed != 0, then af is the factored form of the equilibrated matrix A. If fact = 1, then af is an output argument and on exit returns the factors L and U from the factorization A = P*L*U of the original matrix A. If fact = 2, then af is an output argument and on exit returns the factors L and U from the factorization A = P*L*U of the equilibrated matrix A (see the description of A for the form of the equilibrated matrix). ipiv: If fact = 0, then ipiv is an input argument and on entry contains the pivot indices from the factorization A = P*L*U as computed by getrf; row i of the matrix was interchanged with row ipiv(i). If fact = 1, then ipiv is an output argument and on exit contains the pivot indices from the factorization A = P*L*U of the original matrix A. If fact = 2, then ipiv is an output argument and on exit contains the pivot indices from the factorization A = P*L*U of the equilibrated matrix A. equed: Specifies the form of equilibration that was done. = 0: No equilibration (always true if fact = 1). = 1: Row equilibration, i.e., A has been premultiplied by diag(r). = 2: Column equilibration, i.e., A has been postmultiplied by diag(c). = 3: Both row and column equilibration, i.e., A has been replaced by diag(r) * A * diag(c). equed is an input argument if fact = 0; otherwise, it is an output argument. r: The row scale factors for A. If equed = 1 or 3, A is multiplied on the left by diag(r); if equed = 0 or 2, r is not accessed. r is an input argument if fact = 0; otherwise, r is an output argument. If fact = 0 and equed = 1 or 3, each element of r must be positive. c: The column scale factors for A. If equed = 2 or 3, A is multiplied on the right by diag(c); if equed = 0 or 1, c is not accessed. c is an input argument if fact = 0; otherwise, c is an output argument. If fact = 0 and equed = 2 or 3, each element of c must be positive. B: On entry, the N-by-NRHS right hand side matrix B. On exit, if equed = 0, B is not modified; if trans = 0 and equed = 1 or 3, B is overwritten by diag(r)*B; if trans = 1 or 2 and equed = 2 or 3, B is overwritten by diag(c)*B. X: If info = 0 or info = N+1, the N-by-NRHS solution matrix X to the original system of equations. Note that A and B are modified on exit if equed != 0, and the solution to the equilibrated system is inv(diag(c))*X if trans = 0 and equed = 2 or 3, or inv(diag(r))*X if trans = 1 or 2 and equed = 1 or 3. rcond: The estimate of the reciprocal condition number of the matrix A after equilibration (if done). If rcond is less than the machine precision (in particular, if rcond = 0), the matrix is singular to working precision. This condition is indicated by a return code of info > 0. ferr: The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), ferr(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for rcond, and is almost always a slight overestimate of the true error. berr: The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution). rpvgrw: Contains the reciprocal pivot growth factor norm(A)/norm(U). The "max absolute element" norm is used. If it is much less than 1, then the stability of the LU factorization of the (equilibrated) matrix A could be poor. This also means that the solution X, condition estimator rcond, and forward error bound ferr could be unreliable. If factorization fails with 0 0: if info = i, and i is <= N: U(i,i) is exactly zero. The factorization has been completed, but the factor U is exactly singular, so the solution and error bounds could not be computed. rcond = 0 is returned. = N+1: U is nonsingular, but rcond is less than machine precision, meaning that the matrix is singular to working precision. Nevertheless, the solution and error bounds are computed because there are a number of situations where the computed solution can be more accurate than the value of rcond would suggest. =for example $a= random(5,5); $b = random(5,5); $a = transpose($a); $b = transpose($b); $rcond = pdl(0); $rpvgrw = pdl(0); $equed = pdl(long,0); $info = pdl(long,0); $berr = zeroes(5); $ipiv = zeroes(5); $ferr = zeroes(5); $r = zeroes(5); $c = zeroes(5); $X = zeroes(5,5); $af = zeroes(5,5); gesvx($a,0, 2, $b, $af, $ipiv, $equed, $r, $c, $X, $rcond, $ferr, $berr, $rpvgrw, $info); print "The solution matrix X is :". transpose($X)."\n" unless $info; '); pp_def("sysv", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); [io,phys]B(n,m); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int ssysv_(char *uplo, integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer *ldb, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dsysv_(char *uplo, integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer *ldb, double *work, integer *lwork, integer *info); double tmp_work; %} if ($uplo()) puplo = \'L\'; $TFD(ssysv_,dsysv_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(ssysv_,dsysv_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, work, &lwork, $P(info)); } ', Doc => ' =for ref Computes the solution to a real system of linear equations A * X = B, where A is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. The diagonal pivoting method is used to factor A as A = U * D * U\', if uplo = 0, or A = L * D * L\', if uplo = 1, where U (or L) is a product of permutation and unit upper (lower) triangular matrices, and D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then used to solve the system of equations A * X = B. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, if info = 0, the block diagonal matrix D and the multipliers used to obtain the factor U or L from the factorization A = U*D*U\' or A = L*D*L\' as computed by sytrf. ipiv: Details of the interchanges and the block structure of D, as determined by sytrf. If ipiv(k) > 0, then rows and columns k and ipiv(k) were interchanged, and D(k,k) is a 1-by-1 diagonal block. If uplo = 0 and ipiv(k) = ipiv(k-1) < 0, then rows and columns k-1 and -ipiv(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If uplo = 1 and ipiv(k) = ipiv(k+1) < 0, then rows and columns k+1 and -ipiv(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. B: On entry, the N-by-NRHS right hand side matrix B. On exit, if info = 0, the N-by-NRHS solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, D(i,i) is exactly zero. The factorization has been completed, but the block diagonal matrix D is exactly singular, so the solution could not be computed. =for example # Assume $a is symmetric ;) $a = random (5,5); $a = transpose($a); $b = random(4,5); $b = transpose($b); sysv($a, 1, $b, (my $ipiv=zeroes(5)),(my $info=null)); print "The solution matrix X is :". transpose($b)."\n" unless $info; '); pp_def("sysvx", HandleBad => 0, Pars => '[phys]A(n,n); int uplo(); int fact(); [phys]B(n,m); [io,phys]af(n,n); int [io,phys]ipiv(n); [o,phys]X(n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pfact = \'N\'; char puplo = \'U\'; integer lwork = -1; integer *iwork; types(F) %{ extern int ssysvx_(char *fact, char *uplo, integer *n, integer * nrhs, float *a, integer *lda, float *af, integer *ldaf, integer *ipiv, float *b, integer *ldb, float *x, integer * ldx, float *rcond, float *ferr, float *berr, float *work, integer *lwork, integer *iwork, integer *info); float tmp_work; %} types(D) %{ extern int dsysvx_(char *fact, char *uplo, integer *n, integer * nrhs, double *a, integer *lda, double *af, integer *ldaf, integer *ipiv, double *b, integer *ldb, double *x, integer * ldx, double *rcond, double *ferr, double *berr, double *work, integer *lwork, integer *iwork, integer *info); double tmp_work; %} if($fact()) pfact = \'F\'; if ($uplo()) puplo = \'L\'; iwork = (integer *) malloc ($PRIV(__n_size)* sizeof (integer)); $TFD(ssysvx_,dsysvx_)( &pfact, &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(af), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(X), &(integer){$PRIV(__n_size)}, $P(rcond), $P(ferr), $P(berr), &tmp_work, &lwork, iwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(ssysvx_,dsysvx_)( &pfact, &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(af), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(X), &(integer){$PRIV(__n_size)}, $P(rcond), $P(ferr), $P(berr), work, &lwork, iwork, $P(info)); free(work); } free(iwork); ', Doc => ' =for ref Uses the diagonal pivoting factorization to compute the solution to a real system of linear equations A * X = B, where A is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. Error bounds on the solution and a condition estimate are also provided. The following steps are performed: =over 3 =item 1 If fact = 0, the diagonal pivoting method is used to factor A. The form of the factorization is A = U * D * U\', if uplo = 0, or A = L * D * L\', if uplo = 1, where U (or L) is a product of permutation and unit upper (lower) triangular matrices, and D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. =item 2 If some D(i,i)=0, so that D is exactly singular, then the routine returns with info = i. Otherwise, the factored form of A is used to estimate the condition number of the matrix A. If the reciprocal of the condition number is less than machine precision, info = N+1 is returned as a warning, but the routine still goes on to solve for X and compute error bounds as described below. =item 3 The system of equations is solved for X using the factored form of A. =item 4 Iterative refinement is applied to improve the computed solution matrix and calculate error bounds and backward error estimates for it. =back Arguments ========= fact: Specifies whether or not the factored form of A has been supplied on entry. = 0: The matrix A will be copied to af and factored. = 1: On entry, af and ipiv contain the factored form of A. af and ipiv will not be modified. uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: The symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. af: If fact = 1, then af is an input argument and on entry contains the block diagonal matrix D and the multipliers used to obtain the factor U or L from the factorization A = U*D*U\' or A = L*D*L\' as computed by sytrf. If fact = 0, then af is an output argument and on exit returns the block diagonal matrix D and the multipliers used to obtain the factor U or L from the factorization A = U*D*U\' or A = L*D*L\'. ipiv: If fact = 1, then ipiv is an input argument and on entry contains details of the interchanges and the block structure of D, as determined by sytrf. If ipiv(k) > 0, then rows and columns k and ipiv(k) were interchanged and D(k,k) is a 1-by-1 diagonal block. If uplo = 0 and ipiv(k) = ipiv(k-1) < 0, then rows and columns k-1 and -ipiv(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If uplo = 1 and ipiv(k) = ipiv(k+1) < 0, then rows and columns k+1 and -ipiv(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. If fact = 0, then ipiv is an output argument and on exit contains details of the interchanges and the block structure of D, as determined by sytrf. B: The N-by-NRHS right hand side matrix B. X: If info = 0 or info = N+1, the N-by-NRHS solution matrix X. rcond: The estimate of the reciprocal condition number of the matrix A. If rcond is less than the machine precision (in particular, if rcond = 0), the matrix is singular to working precision. This condition is indicated by a return code of info > 0. ferr: The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), ferr(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for rcond, and is almost always a slight overestimate of the true error. berr: The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, and i is <= N: D(i,i) is exactly zero. The factorization has been completed but the factor D is exactly singular, so the solution and error bounds could not be computed. rcond = 0 is returned. = N+1: D is nonsingular, but rcond is less than machine precision, meaning that the matrix is singular to working precision. Nevertheless, the solution and error bounds are computed because there are a number of situations where the computed solution can be more accurate than the value of rcond would suggest. =for example $a= random(5,5); $b = random(10,5); $a = transpose($a); $b = transpose($b); $X = zeroes($b); $af = zeroes($a); $ipiv = zeroes(long, 5); $rcond = pdl(0); $ferr = zeroes(10); $berr = zeroes(10); $info = pdl(long, 0); # Assume $a is symmetric sysvx($a, 0, 0, $b,$af, $ipiv, $X, $rcond, $ferr, $berr,$info); print "The solution matrix X is :". transpose($X)."\n"; '); pp_def("posv", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); [io,phys]B(n,m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int sposv_(char *uplo, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, integer *info); %} types(D) %{ extern int dposv_(char *uplo, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(sposv_,dposv_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Computes the solution to a real system of linear equations A * X = B, where A is an N-by-N symmetric positive definite matrix and X and B are N-by-NRHS matrices. The Cholesky decomposition is used to factor A as A = U\'* U, if uplo = 0, or A = L * L\', if uplo = 1, where U is an upper triangular matrix and L is a lower triangular matrix. The factored form of A is then used to solve the system of equations A * X = B. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, if info = 0, the factor U or L from the Cholesky factorization A = U\'*U or A = L*L\'. B: On entry, the N-by-NRHS right hand side matrix B. On exit, if info = 0, the N-by-NRHS solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the leading minor of order i of A is not positive definite, so the factorization could not be completed, and the solution has not been computed. =for example # Assume $a is symmetric positive definite ;) $a = random (5,5); $a = transpose($a); $b = random(4,5); $b = transpose($b); posv($a, 1, $b, (my $info=null)); print "The solution matrix X is :". transpose($b)."\n" unless $info; '); pp_def("posvx", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); int fact(); [io,phys]B(n,m); [io,phys]af(n,n); int [io]equed(); [io,phys]s(n); [o,phys]X(n,m); [o,phys]rcond(); [o,phys]ferr(m); [o,phys]berr(m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pfact; char pequed = \'N\'; char puplo = \'U\'; integer *iwork; types(F) %{ extern int sposvx_(char *fact, char *uplo, integer *n, integer * nrhs, float *a, integer *lda, float *af, integer *ldaf, char *equed, float *s, float *b, integer *ldb, float * x, integer *ldx, float *rcond, float *ferr, float * berr, float *work, integer *iwork, integer *info); float *work; %} types(D) %{ extern int dposvx_(char *fact, char *uplo, integer *n, integer * nrhs, double *a, integer *lda, double *af, integer *ldaf, char *equed, double *s, double *b, integer *ldb, double * x, integer *ldx, double *rcond, double *ferr, double * berr, double *work, integer *iwork, integer *info); double *work; %} switch ($fact()) { case 1: pfact = \'N\'; break; case 2: pfact = \'E\'; break; default: pfact = \'F\'; } if ($equed()) pequed = \'Y\'; if ($uplo()) puplo = \'L\'; types(F) %{ work = (float *) malloc(3 * $PRIV(__n_size) * sizeof(float)); %} types(D) %{ work = (double *) malloc(3 * $PRIV(__n_size) * sizeof(double)); %} iwork = (integer *) malloc ($PRIV(__n_size)* sizeof (integer)); $TFD(sposvx_,dposvx_)( &pfact, &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(af), &(integer){$PRIV(__n_size)}, &pequed, $P(s), $P(B), &(integer){$PRIV(__n_size)}, $P(X), &(integer){$PRIV(__n_size)}, $P(rcond), $P(ferr), $P(berr), work, iwork, $P(info)); free(work); free(iwork); switch (pequed) { case \'Y\': $equed() = 1; break; default: $equed()= 0; } ', Doc => ' =for ref Uses the Cholesky factorization A = U\'*U or A = L*L\' to compute the solution to a real system of linear equations A * X = B, where A is an N-by-N symmetric positive definite matrix and X and B are N-by-NRHS matrices. Error bounds on the solution and a condition estimate are also provided. The following steps are performed: =over 3 =item 1 If fact = 2, real scaling factors are computed to equilibrate the system: diag(s) * A * diag(s) * inv(diag(s)) * X = diag(s) * B Whether or not the system will be equilibrated depends on the scaling of the matrix A, but if equilibration is used, A is overwritten by diag(s)*A*diag(s) and B by diag(s)*B. =item 2 If fact = 1 or 2, the Cholesky decomposition is used to factor the matrix A (after equilibration if fact = 2) as A = U\'* U, if uplo = 0, or A = L * L\', if uplo = 1, where U is an upper triangular matrix and L is a lower triangular matrix. =item 3 If the leading i-by-i principal minor is not positive definite, then the routine returns with info = i. Otherwise, the factored form of A is used to estimate the condition number of the matrix A. If the reciprocal of the condition number is less than machine precision, info = N+1 is returned as a warning, but the routine still goes on to solve for X and compute error bounds as described below. =item 4 The system of equations is solved for X using the factored form of A. =item 5 Iterative refinement is applied to improve the computed solution matrix and calculate error bounds and backward error estimates for it. =item 6 If equilibration was used, the matrix X is premultiplied by diag(s) so that it solves the original system before equilibration. =back Arguments ========= fact: Specifies whether or not the factored form of the matrix A is supplied on entry, and if not, whether the matrix A should be equilibrated before it is factored. = 0: On entry, af contains the factored form of A. If equed = 1, the matrix A has been equilibrated with scaling factors given by s. A and af will not be modified. = 1: The matrix A will be copied to af and factored. = 2: The matrix A will be equilibrated if necessary, then copied to af and factored. uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A, except if fact = 0 and equed = 1, then A must contain the equilibrated matrix diag(s)*A*diag(s). If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. A is not modified if fact = 0 or 1, or if fact = 2 and equed = 0 on exit. On exit, if fact = 2 and equed = 1, A is overwritten by diag(s)*A*diag(s). af: If fact = 0, then af is an input argument and on entry contains the triangular factor U or L from the Cholesky factorization A = U\'*U or A = L*L\', in the same storage format as A. If equed != 0, then af is the factored form of the equilibrated matrix diag(s)*A*diag(s). If fact = 1, then af is an output argument and on exit returns the triangular factor U or L from the Cholesky factorization A = U\'*U or A = L*L\' of the original matrix A. If fact = 2, then af is an output argument and on exit returns the triangular factor U or L from the Cholesky factorization A = U\'*U or A = L*L\' of the equilibrated matrix A (see the description of A for the form of the equilibrated matrix). equed: Specifies the form of equilibration that was done. = 0: No equilibration (always true if fact = 1). = 1: Equilibration was done, i.e., A has been replaced by diag(s) * A * diag(s). equed is an input argument if fact = 0; otherwise, it is an output argument. s: The scale factors for A; not accessed if equed = 0. s is an input argument if fact = 0; otherwise, s is an output argument. If fact = 0 and equed = 1, each element of s must be positive. B: On entry, the N-by-NRHS right hand side matrix B. On exit, if equed = 0, B is not modified; if equed = 1, B is overwritten by diag(s) * B. X: If info = 0 or info = N+1, the N-by-NRHS solution matrix X to the original system of equations. Note that if equed = 1, A and B are modified on exit, and the solution to the equilibrated system is inv(diag(s))*X. rcond: The estimate of the reciprocal condition number of the matrix A after equilibration (if done). If rcond is less than the machine precision (in particular, if rcond = 0), the matrix is singular to working precision. This condition is indicated by a return code of info > 0. ferr: The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), FERR(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for rcond, and is almost always a slight overestimate of the true error. berr: The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, and i is <= N: the leading minor of order i of A is not positive definite, so the factorization could not be completed, and the solution has not been computed. rcond = 0 is returned. = N+1: U is nonsingular, but rcond is less than machine precision, meaning that the matrix is singular to working precision. Nevertheless, the solution and error bounds are computed because there are a number of situations where the computed solution can be more accurate than the value of rcond would suggest. =for example $a= random(5,5); $b = random(5,5); $a = transpose($a); $b = transpose($b); # Assume $a is symmetric positive definite $rcond = pdl(0); $equed = pdl(long,0); $info = pdl(long,0); $berr = zeroes(5); $ferr = zeroes(5); $s = zeroes(5); $X = zeroes(5,5); $af = zeroes(5,5); posvx($a,0,2,$b,$af, $equed, $s, $X, $rcond, $ferr, $berr,$info); print "The solution matrix X is :". transpose($X)."\n" unless $info; '); pp_def("gels", HandleBad => 0, Pars => '[io,phys]A(m,n); int trans(); [io,phys]B(p,q);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\'; integer lwork = -1; types(F) %{ extern int sgels_(char *trans, integer *m, integer *n, integer * nrhs, float *a, integer *lda, float *b, integer *ldb, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgels_(char *trans, integer *m, integer *n, integer * nrhs, double *a, integer *lda, double *b, integer *ldb, double *work, integer *lwork, integer *info); double tmp_work; %} if($trans()) ptrans = \'T\'; $TFD(sgels_,dgels_)( &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgels_,dgels_)( &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Solves overdetermined or underdetermined real linear systems involving an M-by-N matrix A, or its transpose, using a QR or LQ factorization of A. It is assumed that A has full rank. The following options are provided: =over 3 =item 1 If trans = 0 and m >= n: find the least squares solution of an overdetermined system, i.e., solve the least squares problem minimize || B - A*X ||. =item 2 If trans = 0 and m < n: find the minimum norm solution of an underdetermined system A * X = B. =item 3 If trans = 1 and m >= n: find the minimum norm solution of an undetermined system A\' * X = B. =item 4 If trans = 1 and m < n: find the least squares solution of an overdetermined system, i.e., solve the least squares problem minimize || B - A\' * X ||. =back Several right hand side vectors b and solution vectors x can be handled in a single call; they are stored as the columns of the M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix X. Arguments ========= trans: = 0: the linear system involves A; = 1: the linear system involves A\'. A: On entry, the M-by-N matrix A. On exit, if M >= N, A is overwritten by details of its QR factorization as returned by geqrf; if M < N, A is overwritten by details of its LQ factorization as returned by gelqf. B: On entry, the matrix B of right hand side vectors, stored columnwise; B is M-by-NRHS if trans = 0, or N-by-NRHS if trans = 1. On exit, B is overwritten by the solution vectors, stored columnwise: if trans = 0 and m >= n, rows 1 to n of B contain the least squares solution vectors; the residual sum of squares for the solution in each column is given by the sum of squares of elements N+1 to M in that column; if trans = 0 and m < n, rows 1 to N of B contain the minimum norm solution vectors; if trans = 1 and m >= n, rows 1 to M of B contain the minimum norm solution vectors; if trans = 1 and m < n, rows 1 to M of B contain the least squares solution vectors; the residual sum of squares for the solution in each column is given by the sum of squares of elements M+1 to N in that column. The leading dimension of the array B >= max(1,M,N). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a= random(7,5); # $b will contain X # TODO better example with slice $b = random(7,6); gels($a, 1, $b, ($info = null)); '); pp_def("gelsy", HandleBad => 0, Pars => '[io,phys]A(m,n); [io,phys]B(p,q); [phys]rcond(); int [io,phys]jpvt(n); int [o,phys]rank();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sgelsy_(integer *m, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, integer * jpvt, float *rcond, integer *rank, float *work, integer * lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgelsy_(integer *m, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, integer * jpvt, double *rcond, integer *rank, double *work, integer * lwork, integer *info); double tmp_work; %} $TFD(sgelsy_,dgelsy_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(jpvt), $P(rcond), $P(rank), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgelsy_,dgelsy_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(jpvt), $P(rcond), $P(rank), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes the minimum-norm solution to a real linear least squares problem: minimize || A * X - B || using a complete orthogonal factorization of A. A is an M-by-N matrix which may be rank-deficient. Several right hand side vectors b and solution vectors x can be handled in a single call; they are stored as the columns of the M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix X. The routine first computes a QR factorization with column pivoting: A * P = Q * [ R11 R12 ] [ 0 R22 ] with R11 defined as the largest leading submatrix whose estimated condition number is less than 1/rcond. The order of R11, rank, is the effective rank of A. Then, R22 is considered to be negligible, and R12 is annihilated by orthogonal transformations from the right, arriving at the complete orthogonal factorization: A * P = Q * [ T11 0 ] * Z [ 0 0 ] The minimum-norm solution is then X = P * Z\' [ inv(T11)*Q1\'*B ] [ 0 ] where Q1 consists of the first rank columns of Q. Arguments ========= A: On entry, the M-by-N matrix A. On exit, A has been overwritten by details of its complete orthogonal factorization. B: On entry, the M-by-NRHS right hand side matrix B. On exit, the N-by-NRHS solution matrix X. The leading dimension of the array B >= max(1,M,N). jpvt: On entry, if jpvt(i) != 0, the i-th column of A is permuted to the front of AP, otherwise column i is a free column. On exit, if jpvt(i) = k, then the i-th column of AP was the k-th column of A. rcond: rcond is used to determine the effective rank of A, which is defined as the order of the largest leading triangular submatrix R11 in the QR factorization with pivoting of A, whose estimated condition number < 1/rcond. rank: The effective rank of A, i.e., the order of the submatrix R11. This is the same as the order of the submatrix T11 in the complete orthogonal factorization of A. info: = 0: successful exit < 0: If info = -i, the i-th argument had an illegal value. =for example $a= random(7,5); # $b will contain X # TODO better example with slice $b = random(7,6); $jpvt = zeroes(long, 5); $eps = lamch(0); #Threshold for rank estimation $rcond = sqrt($eps) - (sqrt($eps) - $eps) / 2; gelsy($a, $b, $rcond, $jpvt,($rank=null),($info = null)); '); pp_def("gelss", HandleBad => 0, Pars => '[io,phys]A(m,n); [io,phys]B(p,q); [phys]rcond(); [o,phys]s(r); int [o,phys]rank();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sgelss_(integer *m, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, float *s, float *rcond, integer *rank, float *work, integer * lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgelss_(integer *m, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, double *s,double *rcond, integer *rank, double *work, integer * lwork, integer *info); double tmp_work; %} $TFD(sgelss_,dgelss_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(s), $P(rcond), $P(rank), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgelss_,dgelss_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(s), $P(rcond), $P(rank), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes the minimum norm solution to a real linear least squares problem: Minimize 2-norm(| b - A*x |). using the singular value decomposition (SVD) of A. A is an M-by-N matrix which may be rank-deficient. Several right hand side vectors b and solution vectors x can be handled in a single call; they are stored as the columns of the M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix X. The effective rank of A is determined by treating as zero those singular values which are less than rcond times the largest singular value. Arguments ========= A: On entry, the M-by-N matrix A. On exit, the first min(m,n) rows of A are overwritten with its right singular vectors, stored rowwise. B: On entry, the M-by-NRHS right hand side matrix B. On exit, B is overwritten by the N-by-NRHS solution matrix X. If m >= n and rank = n, the residual sum-of-squares for the solution in the i-th column is given by the sum of squares of elements n+1:m in that column. The leading dimension of the array B >= max(1,M,N). s: The singular values of A in decreasing order. The condition number of A in the 2-norm = s(1)/s(min(m,n)). rcond: rcond is used to determine the effective rank of A. Singular values s(i) <= rcond*s(1) are treated as zero. If rcond < 0, machine precision is used instead. rank: The effective rank of A, i.e., the number of singular values which are greater than rcond*s(1). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: the algorithm for computing the SVD failed to converge; if info = i, i off-diagonal elements of an intermediate bidiagonal form did not converge to zero. =for example $a= random(7,5); # $b will contain X # TODO better example with slice $b = random(7,6); $eps = lamch(0); $s =zeroes(5); #Threshold for rank estimation $rcond = sqrt($eps) - (sqrt($eps) - $eps) / 2; gelss($a, $b, $rcond, $s, ($rank=null),($info = null)); '); pp_def("gelsd", HandleBad => 0, Pars => '[io,phys]A(m,n); [io,phys]B(p,q); [phys]rcond(); [o,phys]s(r); int [o,phys]rank();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; integer smlsiz, size_i, nlvl, *iwork; integer minmn = min( $SIZE(m), $SIZE(n) ); extern integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen opts_len); types(F) %{ extern int sgelsd_(integer *m, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, float *s, float *rcond, integer *rank, float *work, integer * lwork, integer *iwork, integer *info); float tmp_work; %} types(D) %{ extern int dgelsd_(integer *m, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, double *s,double *rcond, integer *rank, double *work, integer * lwork, integer *iwork,integer *info); double tmp_work; %} minmn = max(1,minmn); types(F) %{ smlsiz = ilaenv_(&c_nine, "SGELSD", " ", &c_zero, &c_zero, &c_zero, &c_zero, (ftnlen)6, (ftnlen)1); size_i = (integer) (log((float) minmn / (float) (smlsiz + 1)) /log(2.)) + 1; %} types(D) %{ smlsiz = ilaenv_(&c_nine, "DGELSD", " ", &c_zero, &c_zero, &c_zero, &c_zero, (ftnlen)6, (ftnlen)1); size_i = (integer) (log((double) minmn / (double) (smlsiz + 1)) /log(2.)) + 1; %} nlvl = max(size_i, 0); iwork = (integer *)malloc((3 * minmn * nlvl + 11 * minmn) * sizeof(integer)); $TFD(sgelsd_,dgelsd_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(s), $P(rcond), $P(rank), &tmp_work, &lwork, iwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgelsd_,dgelsd_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__q_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(s), $P(rcond), $P(rank), work, &lwork, iwork, $P(info)); free(work); } free (iwork); ', Doc => ' =for ref Computes the minimum-norm solution to a real linear least squares problem: minimize 2-norm(| b - A*x |) using the singular value decomposition (SVD) of A. A is an M-by-N matrix which may be rank-deficient. Several right hand side vectors b and solution vectors x can be handled in a single call; they are stored as the columns of the M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix X. The problem is solved in three steps: =over 3 =item 1 Reduce the coefficient matrix A to bidiagonal form with Householder transformations, reducing the original problem into a "bidiagonal least squares problem" (BLS) =item 2 Solve the BLS using a divide and conquer approach. =item 3 Apply back all the Householder tranformations to solve the original least squares problem. =back The effective rank of A is determined by treating as zero those singular values which are less than rcond times the largest singular value. The divide and conquer algorithm makes very mild assumptions about floating point arithmetic. It will work on machines with a guard digit in add/subtract, or on those binary machines without guard digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. It could conceivably fail on hexadecimal or decimal machines without guard digits, but we know of none. Arguments ========= A: On entry, the M-by-N matrix A. On exit, A has been destroyed. B: On entry, the M-by-NRHS right hand side matrix B. On exit, B is overwritten by the N-by-NRHS solution matrix X. If m >= n and rank = n, the residual sum-of-squares for the solution in the i-th column is given by the sum of squares of elements n+1:m in that column. The leading dimension of the array B >= max(1,M,N). s: The singular values of A in decreasing order. The condition number of A in the 2-norm = s(1)/s(min(m,n)). rcond: rcond is used to determine the effective rank of A. Singular values s(i) <= rcond*s(1) are treated as zero. If rcond < 0, machine precision is used instead. rank: The effective rank of A, i.e., the number of singular values which are greater than rcond*s(1). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. > 0: the algorithm for computing the SVD failed to converge; if info = i, i off-diagonal elements of an intermediate bidiagonal form did not converge to zero. =for example $a= random(7,5); # $b will contain X # TODO better example with slice $b = random(7,6); $eps = lamch(0); $s =zeroes(5); #Threshold for rank estimation $rcond = sqrt($eps) - (sqrt($eps) - $eps) / 2; gelsd($a, $b, $rcond, $s, ($rank=null),($info = null)); '); pp_def("gglse", HandleBad => 0, Pars => '[phys]A(m,n); [phys]B(p,n);[io,phys]c(m);[phys]d(p);[o,phys]x(n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sgglse_(integer *m, integer *n, integer *p, float * a, integer *lda, float *b, integer *ldb, float *c__, float *d__, float *x, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgglse_(integer *m, integer *n, integer *p, double * a, integer *lda, double *b, integer *ldb, double *c__, double *d__, double *x, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sgglse_,dgglse_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(c), $P(d), $P(x), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgglse_,dgglse_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(c), $P(d), $P(x), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Solves the linear equality-constrained least squares (LSE) problem: minimize || c - A*x ||_2 subject to B*x = d where A is an M-by-N matrix, B is a P-by-N matrix, c is a given M-vector, and d is a given P-vector. It is assumed that P <= N <= M+P, and rank(B) = P and rank( ( A ) ) = N. ( ( B ) ) These conditions ensure that the LSE problem has a unique solution, which is obtained using a GRQ factorization of the matrices B and A. Arguments ========= A: On entry, the M-by-N matrix A. On exit, A is destroyed. B: On entry, the P-by-N matrix B. On exit, B is destroyed. c: On entry, c contains the right hand side vector for the least squares part of the LSE problem. On exit, the residual sum of squares for the solution is given by the sum of squares of elements N-P+1 to M of vector c. d: On entry, d contains the right hand side vector for the constrained equation. On exit, d is destroyed. x: On exit, x is the solution of the LSE problem. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random(7,5); $b = random(4,5); $c = random(7); $d = random(4); $x = zeroes(5); gglse($a, $b, $c, $d, $x, ($info=null)); '); pp_def("ggglm", HandleBad => 0, Pars => '[phys]A(n,m); [phys]B(n,p);[phys]d(n);[o,phys]x(m);[o,phys]y(p);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sggglm_(integer *n, integer *m, integer *p, float * a, integer *lda, float *b, integer *ldb, float *d__, float *x, float *y, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dggglm_(integer *n, integer *m, integer *p, double * a, integer *lda, double *b, integer *ldb, double *d__, double *x, double *y, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sggglm_,dggglm_)( &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(d), $P(x), $P(y), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sggglm_,dggglm_)( &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(d), $P(x), $P(y), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Solves a general Gauss-Markov linear model (GLM) problem: minimize || y ||_2 subject to d = A*x + B*y x where A is an N-by-M matrix, B is an N-by-P matrix, and d is a given N-vector. It is assumed that M <= N <= M+P, and rank(A) = M and rank( A B ) = N. Under these assumptions, the constrained equation is always consistent, and there is a unique solution x and a minimal 2-norm solution y, which is obtained using a generalized QR factorization of A and B. In particular, if matrix B is square nonsingular, then the problem GLM is equivalent to the following weighted linear least squares problem minimize || inv(B)*(d-A*x) ||_2 x where inv(B) denotes the inverse of B. Arguments ========= A: On entry, the N-by-M matrix A. On exit, A is destroyed. B: On entry, the N-by-P matrix B. On exit, B is destroyed. d: On entry, d is the left hand side of the GLM equation. On exit, d is destroyed. x: y: On exit, x and y are the solutions of the GLM problem. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random(7,5); $b = random(7,4); $d = random(7); $x = zeroes(5); $y = zeroes(4); ggglm($a, $b, $d, $x, $y,($info=null)); '); ################################################################################ # # COMPUTATIONAL LEVEL ROUTINES # ################################################################################ # TODO IPIV = min(m,n) pp_def("getrf", HandleBad => 0, RedoDimsCode => '$SIZE(p) = $PDL(A)->ndims > 1 ? min($PDL(A)->dims[0], $PDL(A)->dims[1]) : 1;', Pars => '[io,phys]A(m,n); int [o,phys]ipiv(p); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' types(F) %{ extern int sgetrf_(integer *m, integer *n, float *a, integer * lda, integer *ipiv, integer *info); %} types(D) %{ extern int dgetrf_(integer *m, integer *n, double *a, integer * lda, integer *ipiv, integer *info); %} $TFD(sgetrf_,dgetrf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(ipiv), $P(info)); ', Doc => ' =for ref Computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges. The factorization has the form A = P * L * U where P is a permutation matrix, L is lower triangular with unit diagonal elements (lower trapezoidal if m > n), and U is upper triangular (upper trapezoidal if m < n). This is the right-looking Level 3 BLAS version of the algorithm. Arguments ========= A: On entry, the M-by-N matrix to be factored. On exit, the factors L and U from the factorization A = P*L*U; the unit diagonal elements of L are not stored. ipiv: The pivot indices; for 1 <= i <= min(M,N), row i of the matrix was interchanged with row ipiv(i). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, U(i,i) is exactly zero. The factorization has been completed, but the factor U is exactly singular, and division by zero will occur if it is used to solve a system of equations. =for example $a = random (float, 100,50); $ipiv = zeroes(long, 50); $info = null; getrf($a, $ipiv, $info); '); pp_def("getf2", HandleBad => 0, RedoDimsCode => '$SIZE(p) = $PDL(A)->ndims > 1 ? min($PDL(A)->dims[0], $PDL(A)->dims[1]) : 1;', Pars => '[io,phys]A(m,n); int [o,phys]ipiv(p); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' types(F) %{ extern int sgetf2_(integer *m, integer *n, float *a, integer * lda, integer *ipiv, integer *info); %} types(D) %{ extern int dgetf2_(integer *m, integer *n, double *a, integer * lda, integer *ipiv, integer *info); %} $TFD(sgetf2_,dgetf2_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(ipiv), $P(info)); ', Doc => ' =for ref Computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges. The factorization has the form A = P * L * U where P is a permutation matrix, L is lower triangular with unit diagonal elements (lower trapezoidal if m > n), and U is upper triangular (upper trapezoidal if m < n). This is the right-looking Level 2 BLAS version of the algorithm. Arguments ========= A: On entry, the M-by-N matrix to be factored. On exit, the factors L and U from the factorization A = P*L*U; the unit diagonal elements of L are not stored. ipiv: The pivot indices; for 1 <= i <= min(M,N), row i of the matrix was interchanged with row ipiv(i). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, U(i,i) is exactly zero. The factorization has been completed, but the factor U is exactly singular, and division by zero will occur if it is used to solve a system of equations. =for example $a = random (float, 100,50); $ipiv = zeroes(long, 50); $info = null; getf2($a, $ipiv, $info); '); pp_def("sytrf", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; integer lwork = -1; types(F) %{ extern int ssytrf_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dsytrf_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, double *work, integer *lwork, integer *info); double tmp_work; %} if ($uplo()) puplo = \'L\'; $TFD(ssytrf_,dsytrf_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(ssytrf_,dsytrf_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), work, &lwork, $P(info)); free (work); } ', Doc => ' =for ref Computes the factorization of a real symmetric matrix A using the Bunch-Kaufman diagonal pivoting method. The form of the factorization is A = U*D*U\' or A = L*D*L\' where U (or L) is a product of permutation and unit upper (lower) triangular matrices, and D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. This is the blocked version of the algorithm, calling Level 3 BLAS. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, the block diagonal matrix D and the multipliers used to obtain the factor U or L (see below for further details). ipiv: Details of the interchanges and the block structure of D. If ipiv(k) > 0, then rows and columns k and ipiv(k) were interchanged and D(k,k) is a 1-by-1 diagonal block. If uplo = 0 and ipiv(k) = ipiv(k-1) < 0, then rows and columns k-1 and -ipiv(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If uplo = 1 and ipiv(k) = ipiv(k+1) < 0, then rows and columns k+1 and -ipiv(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, D(i,i) is exactly zero. The factorization has been completed, but the block diagonal matrix D is exactly singular, and division by zero will occur if it is used to solve a system of equations. Further Details =============== If uplo = 0, then A = U*D*U\', where U = P(n)*U(n)* ... *P(k)U(k)* ..., i.e., U is a product of terms P(k)*U(k), where k decreases from n to 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as defined by ipiv(k), and U(k) is a unit upper triangular matrix, such that if the diagonal block D(k) is of order s (s = 1 or 2), then ( I v 0 ) k-s U(k) = ( 0 I 0 ) s ( 0 0 I ) n-k k-s s n-k If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), and A(k,k), and v overwrites A(1:k-2,k-1:k). If uplo = 1, then A = L*D*L\', where L = P(1)*L(1)* ... *P(k)*L(k)* ..., i.e., L is a product of terms P(k)*L(k), where k increases from 1 to n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as defined by ipiv(k), and L(k) is a unit lower triangular matrix, such that if the diagonal block D(k) is of order s (s = 1 or 2), then ( I 0 0 ) k-1 L(k) = ( 0 I 0 ) s ( 0 v I ) n-k-s+1 k-1 s n-k-s+1 If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). =for example $a = random(100,100); $ipiv = zeroes(100); $info = null; # Assume $a is symmetric sytrf($a, 0, $ipiv, $info); '); pp_def("sytf2", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); int [o,phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int ssytf2_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, integer *info); %} types(D) %{ extern int dsytf2_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(ssytf2_,dsytf2_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(info)); ', Doc => ' =for ref Computes the factorization of a real symmetric matrix A using the Bunch-Kaufman diagonal pivoting method. The form of the factorization is A = U*D*U\' or A = L*D*L\' where U (or L) is a product of permutation and unit upper (lower) triangular matrices, and D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. This is the unblocked version of the algorithm, calling Level 2 BLAS. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, the block diagonal matrix D and the multipliers used to obtain the factor U or L (see below for further details). ipiv: Details of the interchanges and the block structure of D. If ipiv(k) > 0, then rows and columns k and ipiv(k) were interchanged and D(k,k) is a 1-by-1 diagonal block. If uplo = 0 and ipiv(k) = ipiv(k-1) < 0, then rows and columns k-1 and -ipiv(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If uplo = 1 and ipiv(k) = ipiv(k+1) < 0, then rows and columns k+1 and -ipiv(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, D(i,i) is exactly zero. The factorization has been completed, but the block diagonal matrix D is exactly singular, and division by zero will occur if it is used to solve a system of equations. For further details see sytrf =for example $a = random(100,100); $ipiv = zeroes(100); $info = null; # Assume $a is symmetric sytf2($a, 0, $ipiv, $info); '); pp_def("potrf", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int spotrf_(char *uplo, integer *n, float *a, integer * lda, integer *info); %} types(D) %{ extern int dpotrf_(char *uplo, integer *n, double *a, integer * lda, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(spotrf_,dpotrf_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Computes the Cholesky factorization of a real symmetric positive definite matrix A. The factorization has the form A = U\' * U, if uplo = 0, or A = L * L\', if uplo = 1, where U is an upper triangular matrix and L is lower triangular. This is the block version of the algorithm, calling Level 3 BLAS. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, if info = 0, the factor U or L from the Cholesky factorization A = U\'*U or A = L*L\'. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the leading minor of order i is not positive definite, and the factorization could not be completed. =for example $a = random(100,100); # Assume $a is symmetric positive definite potrf($a, 0, ($info = null)); '); pp_def("potf2", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int spotf2_(char *uplo, integer *n, float *a, integer * lda, integer *info); %} types(D) %{ extern int dpotf2_(char *uplo, integer *n, double *a, integer * lda, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(spotf2_,dpotf2_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Computes the Cholesky factorization of a real symmetric positive definite matrix A. The factorization has the form A = U\' * U, if uplo = 0, or A = L * L\', if uplo = 1, where U is an upper triangular matrix and L is lower triangular. This is the unblocked version of the algorithm, calling Level 2 BLAS. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the symmetric matrix A. If uplo = 0, the leading N-by-N upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, if info = 0, the factor U or L from the Cholesky factorization A = U\'*U or A = L*L\'. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the leading minor of order i is not positive definite, and the factorization could not be completed. =for example $a = random(100,100); # Assume $a is symmetric positive definite potf2($a, 0, ($info = null)); '); pp_def("getri", HandleBad => 0, Pars => '[io,phys]A(n,n); int [phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sgetri_(integer *n, float *a, integer *lda, integer *ipiv, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgetri_(integer *n, double *a, integer *lda, integer *ipiv, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sgetri_,dgetri_)( &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgetri_,dgetri_)( &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes the inverse of a matrix using the LU factorization computed by C. This method inverts U and then computes inv(A) by solving the system inv(A)*L = inv(U) for inv(A). Arguments ========= A: On entry, the factors L and U from the factorization A = P*L*U as computed by getrf. On exit, if info = 0, the inverse of the original matrix A. ipiv: The pivot indices from getrf; for 1<=i<=N, row i of the matrix was interchanged with row ipiv(i). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, U(i,i) is exactly zero; the matrix is singular and its inverse could not be computed. =for example $a = random (float, 100, 100); $ipiv = zeroes(long, 100); $info = null; getrf($a, $ipiv, $info); if ($info == 0){ getri($a, $ipiv, $info); } print "Inverse of \$a is :\n $a" unless $info; '); pp_def("sytri", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); int [phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int ssytri_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, float *work, integer *info); float *work = (float *)malloc($PRIV(__n_size) * sizeof(float)); %} types(D) %{ extern int dsytri_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, double *work, integer *info); double *work = (double *)malloc($PRIV(__n_size) * sizeof(double)); %} if ($uplo()) puplo = \'L\'; $TFD(ssytri_, dsytri_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), work, $P(info)); free(work); ', Doc => ' =for ref Computes the inverse of a real symmetric indefinite matrix A using the factorization A = U*D*U\' or A = L*D*L\' computed by C. Arguments ========= uplo: Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 0: Upper triangular, form is A = U*D*U\'; = 1: Lower triangular, form is A = L*D*L\'. A: On entry, the block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by sytrf. On exit, if info = 0, the (symmetric) inverse of the original matrix. If uplo = 0, the upper triangular part of the inverse is formed and the part of A below the diagonal is not referenced; if uplo = 1 the lower triangular part of the inverse is formed and the part of A above the diagonal is not referenced. ipiv: Details of the interchanges and the block structure of D as determined by sytrf. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, D(i,i) = 0; the matrix is singular and its inverse could not be computed. =for example $a = random (float, 100, 100); # assume $a is symmetric $ipiv = zeroes(long, 100); sytrf($a, 0, $ipiv, ($info=null)); if ($info == 0){ sytri($a, 0, $ipiv, $info); } print "Inverse of \$a is :\n $a" unless $info; '); pp_def("potri", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int spotri_(char *uplo, integer *n, float *a, integer * lda, integer *info); %} types(D) %{ extern int dpotri_(char *uplo, integer *n, double *a, integer * lda, integer *info); %} if ($uplo()) puplo = \'L\'; $TFD(spotri_,dpotri_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Computes the inverse of a real symmetric positive definite matrix A using the Cholesky factorization A = U\'*U or A = L*L\' computed by C. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: On entry, the triangular factor U or L from the Cholesky factorization A = U\'*U or A = L*L\', as computed by potrf. On exit, the upper or lower triangle of the (symmetric) inverse of A, overwriting the input factor U or L. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the (i,i) element of the factor U or L is zero, and the inverse could not be computed. =for example $a = random (float, 100, 100); # Assume $a is symmetric positive definite potrf($a, 0, ($info = null)); if ($info == 0){ # Hum... is it positive definite???? potri($a, 0,$info); } print "Inverse of \$a is :\n $a" unless $info; '); pp_def("trtri", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); int diag(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; char pdiag = \'N\'; types(F) %{ extern int strtri_(char *uplo, char *diag, integer *n, float *a, integer * lda, integer *info); %} types(D) %{ extern int dtrtri_(char *uplo, char *diag, integer *n, double *a, integer * lda, integer *info); %} if ($uplo()) puplo = \'L\'; if ($diag()) pdiag = \'U\'; $TFD(strtri_, dtrtri_)( &puplo, &pdiag, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Computes the inverse of a real upper or lower triangular matrix A. This is the Level 3 BLAS version of the algorithm. Arguments ========= uplo: = 0: A is upper triangular; = 1: A is lower triangular. diag: = 0: A is non-unit triangular; = 1: A is unit triangular. A: On entry, the triangular matrix A. If uplo = 0, the leading N-by-N upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If diag = 1, the diagonal elements of A are also not referenced and are assumed to be 1. On exit, the (triangular) inverse of the original matrix, in the same storage format. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, A(i,i) is exactly zero. The triangular matrix is singular and its inverse can not be computed. =for example $a = random (float, 100, 100); # assume $a is upper triangular trtri($a, 1, ($info=null)); print "Inverse of \$a is :\n transpose($a)" unless $info; '); pp_def("trti2", HandleBad => 0, Pars => '[io,phys]A(n,n); int uplo(); int diag(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; char pdiag = \'N\'; types(F) %{ extern int strti2_(char *uplo, char *diag, integer *n, float *a, integer * lda, integer *info); %} types(D) %{ extern int dtrti2_(char *uplo, char *diag, integer *n, double *a, integer * lda, integer *info); %} if ($uplo()) puplo = \'L\'; if ($diag()) pdiag = \'U\'; $TFD(strti2_, dtrti2_)( &puplo, &pdiag, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Computes the inverse of a real upper or lower triangular matrix A. This is the Level 2 BLAS version of the algorithm. Arguments ========= uplo: = 0: A is upper triangular; = 1: A is lower triangular. diag: = 0: A is non-unit triangular; = 1: A is unit triangular. A: On entry, the triangular matrix A. If uplo = 0, the leading N-by-N upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If diag = 1, the diagonal elements of A are also not referenced and are assumed to be 1. On exit, the (triangular) inverse of the original matrix, in the same storage format. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 100); # assume $a is upper triangular trtri2($a, 1, ($info=null)); print "Inverse of \$a is :\n transpose($a)" unless $info; '); pp_def("getrs", HandleBad => 0, Pars => '[phys]A(n,n); int trans(); [io,phys]B(n,m); int [phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char transp = \'N\'; types(F) %{ extern int sgetrs_(char *trans, integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer * ldb, integer *info); %} types(D) %{ extern int dgetrs_(char *trans, integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer * ldb, integer *info); %} if($trans()) transp = \'T\'; $TFD(sgetrs_,dgetrs_)( &transp, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref 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. Arguments ========= trans: Specifies the form of the system of equations: = 0: A * X = B (No transpose) = 1: A\'* X = B (Transpose) A: The factors L and U from the factorization A = P*L*U as computed by getrf. ipiv: The pivot indices from getrf; for 1<=i<=N, row i of the matrix was interchanged with row ipiv(i). B: On entry, the right hand side matrix B. On exit, the solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 100); $ipiv = zeroes(long, 100); $b = random(100,50); getrf($a, $ipiv, ($info=null)); if ($info == 0){ getrs($a, 0, $b, $ipiv, $info); } print "X is :\n $b" unless $info; '); pp_def("sytrs", HandleBad => 0, Pars => '[phys]A(n,n); int uplo();[io,phys]B(n,m); int [phys]ipiv(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int ssytrs_(char *uplo, integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer * ldb, integer *info); %} types(D) %{ extern int dsytrs_(char *uplo, integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer * ldb, integer *info); %} if($uplo()) puplo = \'L\'; $TFD(ssytrs_,dsytrs_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Solves a system of linear equations A*X = B with a real symmetric matrix A using the factorization A = U*D*U\' or A = L*D*L\' computed by C. Arguments ========= uplo: Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 0: Upper triangular, form is A = U*D*U\'; = 1: Lower triangular, form is A = L*D*L\'. A: The block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by sytrf. ipiv: Details of the interchanges and the block structure of D as determined by sytrf. B: On entry, the right hand side matrix B. On exit, the solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 100); $b = random(50,100); $a = transpose($a); $b = transpose($b); # Assume $a is symmetric sytrf($a, 0, ($ipiv=zeroes(100)), ($info=null)); if ($info == 0){ sytrs($a, 0, $b, $ipiv, $info); } print("X is :\n".transpose($b))unless $info; '); pp_def("potrs", HandleBad => 0, Pars => '[phys]A(n,n); int uplo(); [io,phys]B(n,m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int spotrs_(char *uplo, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, integer * info); %} types(D) %{ extern int dpotrs_(char *uplo, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, integer * info); %} if($uplo()) puplo = \'L\'; $TFD(spotrs_,dpotrs_)( &puplo, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Solves a system of linear equations A*X = B with a symmetric positive definite matrix A using the Cholesky factorization A = U\'*U or A = L*L\' computed by C. Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: The triangular factor U or L from the Cholesky factorization A = U\'*U or A = L*L\', as computed by potrf. B: On entry, the right hand side matrix B. On exit, the solution matrix X. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 100); $b = random(50,100); $a = transpose($a); $b = transpose($b); # Assume $a is symmetric positive definite potrf($a, 0, ($info=null)); if ($info == 0){ potrs($a, 0, $b, $info); } print("X is :\n".transpose($b))unless $info; '); pp_def("trtrs", HandleBad => 0, Pars => '[phys]A(n,n); int uplo(); int trans(); int diag();[io,phys]B(n,m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; char ptrans = \'N\'; char pdiag = \'N\'; types(F) %{ extern int strtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer * ldb, integer *info); %} types(D) %{ extern int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer * ldb, integer *info); %} if($uplo()) puplo = \'L\'; if($trans()) ptrans = \'T\'; if($diag()) pdiag = \'U\'; $TFD(strtrs_,dtrtrs_)( &puplo, &ptrans, &pdiag, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref Solves a triangular system of the form A * X = B or A\' * X = B, where A is a triangular matrix of order N, and B is an N-by-NRHS matrix. A check is made to verify that A is nonsingular. Arguments ========= uplo: = 0: A is upper triangular; = 1: A is lower triangular. trans: Specifies the form of the system of equations: = 0: A * X = B (No transpose) = 1: A**T * X = B (Transpose) diag: = 0: A is non-unit triangular; = 1: A is unit triangular. A: The triangular matrix A. If uplo = 0, the leading N-by-N upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If diag = 1, the diagonal elements of A are also not referenced and are assumed to be 1. B: On entry, the right hand side matrix B. On exit, if info = 0, the solution matrix X. info = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, the i-th diagonal element of A is zero, indicating that the matrix is singular and the solutions X have not been computed. =for example # Assume $a is upper triangular $a = random (float, 100, 100); $b = random(50,100); $a = transpose($a); $b = transpose($b); $info = null; trtrs($a, 0, 0, 0, $b, $info); print("X is :\n".transpose($b))unless $info; '); pp_def("latrs", HandleBad => 0, Pars => '[phys]A(n,n); int uplo(); int trans(); int diag(); int normin();[io,phys]x(n); [o,phys]scale();[io,phys]cnorm(n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; char ptrans = \'N\'; char pdiag = \'N\'; char pnormin = \'N\'; types(F) %{ extern int slatrs_(char *uplo, char *trans, char *diag, char * normin, integer *n, float *a, integer *lda, float *x, float *scale, float *cnorm, integer *info); %} types(D) %{ extern int dlatrs_(char *uplo, char *trans, char *diag, char * normin, integer *n, double *a, integer *lda, double *x, double *scale, double *cnorm, integer *info); %} if($uplo()) puplo = \'L\'; if($trans()) ptrans = \'T\'; if($diag()) pdiag = \'U\'; if($normin()) pnormin = \'Y\'; $TFD(slatrs_,dlatrs_)( &puplo, &ptrans, &pdiag, &pnormin, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(x), $P(scale), $P(cnorm), $P(info)); ', Doc => ' =for ref Solves one of the triangular systems A *x = s*b or A\'*x = s*b with scaling to prevent overflow. Here A is an upper or lower triangular matrix, A\' denotes the transpose of A, x and b are n-element vectors, and s is a scaling factor, usually less than or equal to 1, chosen so that the components of x will be less than the overflow threshold. If the unscaled problem will not cause overflow, the Level 2 BLAS routine C is called. If the matrix A is singular (A(j,j) = 0 for some j), then s is set to 0 and a non-trivial solution to A*x = 0 is returned. Further Details ======= ======= A rough bound on x is computed; if that is less than overflow, trsv is called, otherwise, specific code is used which checks for possible overflow or divide-by-zero at every operation. A columnwise scheme is used for solving A*x = b. The basic algorithm if A is lower triangular is x[1:n] := b[1:n] for j = 1, ..., n x(j) := x(j) / A(j,j) x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] end Define bounds on the components of x after j iterations of the loop: M(j) = bound on x[1:j] G(j) = bound on x[j+1:n] Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. Then for iteration j+1 we have M(j+1) <= G(j) / | A(j+1,j+1) | G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | <= G(j) ( 1 + cnorm(j+1) / | A(j+1,j+1) | ) where cnorm(j+1) is greater than or equal to the infinity-norm of column j+1 of A, not counting the diagonal. Hence G(j) <= G(0) product ( 1 + cnorm(i) / | A(i,i) | ) 1<=i<=j and |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + cnorm(i) / |A(i,i)| ) 1<=i< j Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the reciprocal of the largest M(j), j=1,..,n, is larger than max(underflow, 1/overflow). The bound on x(j) is also used to determine when a step in the columnwise method can be performed without fear of overflow. If the computed bound is greater than a large constant, x is scaled to prevent overflow, but if the bound overflows, x is set to 0, x(j) to 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. Similarly, a row-wise scheme is used to solve A\'*x = b. The basic algorithm for A upper triangular is for j = 1, ..., n x(j) := ( b(j) - A[1:j-1,j]\' * x[1:j-1] ) / A(j,j) end We simultaneously compute two bounds G(j) = bound on ( b(i) - A[1:i-1,i]\' * x[1:i-1] ), 1<=i<=j M(j) = bound on x(i), 1<=i<=j The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. Then the bound on x(j) is M(j) <= M(j-1) * ( 1 + cnorm(j) ) / | A(j,j) | <= M(0) * product ( ( 1 + cnorm(i) ) / |A(i,i)| ) 1<=i<=j and we can safely call trsv if 1/M(n) and 1/G(n) are both greater than max(underflow, 1/overflow). Arguments ========= uplo: Specifies whether the matrix A is upper or lower triangular. = 0: Upper triangular = 1: Lower triangular trans: Specifies the operation applied to A. = 0: Solve A * x = s*b (No transpose) = 1: Solve A\'* x = s*b (Transpose) diag: Specifies whether or not the matrix A is unit triangular. = 0: Non-unit triangular = 1: Unit triangular normin: Specifies whether cnorm has been set or not. = 1: cnorm contains the column norms on entry = 0: cnorm is not set on entry. On exit, the norms will be computed and stored in cnorm. A: The triangular matrix A. If uplo = 0, the leading n by n upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading n by n lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If diag = 1, the diagonal elements of A are also not referenced and are assumed to be 1. x: On entry, the right hand side b of the triangular system. On exit, x is overwritten by the solution vector x. scale: The scaling factor s for the triangular system A * x = s*b or A\'* x = s*b. If scale = 0, the matrix A is singular or badly scaled, and the vector x is an exact or approximate solution to A*x = 0. cnorm: If normin = 0, cnorm is an output argument and cnorm(j) returns the 1-norm of the offdiagonal part of the j-th column of A. If normin = 1, cnorm is an input argument and cnorm(j) contains the norm of the off-diagonal part of the j-th column of A. If trans = 0, cnorm(j) must be greater than or equal to the infinity-norm, and if trans = 1, cnorm(j) must be greater than or equal to the 1-norm. info: = 0: successful exit < 0: if info = -k, the k-th argument had an illegal value =for example # Assume $a is upper triangular $a = random (float, 100, 100); $b = random(100); $a = transpose($a); $info = null; $scale= null; $cnorm = zeroes(100); latrs($a, 0, 0, 0, 0,$b, $scale, $cnorm,$info); '); pp_def("gecon", HandleBad => 0, Pars => '[phys]A(n,n); int norm(); [phys]anorm(); [o,phys]rcond();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pnorm = \'I\'; types(F) %{ extern int sgecon_(char *norm, integer *n, float *a, integer * lda, float *anorm, float *rcond, float *work, integer * iwork, integer *info); float *work = (float *) malloc(($PRIV(__n_size) * 4) * sizeof(float)); %} types(D) %{ extern int dgecon_(char *norm, integer *n, double *a, integer * lda, double *anorm, double *rcond, double *work, integer * iwork, integer *info); double *work = (double *) malloc(($PRIV(__n_size)*4) * sizeof(double)); %} integer *iwork = (integer *) malloc($PRIV(__n_size) * sizeof(integer)); if($norm()) pnorm = \'O\'; $TFD(sgecon_,dgecon_)( &pnorm, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(anorm), $P(rcond), work, iwork, $P(info)); free (work); free(iwork); ', Doc => ' =for ref Estimates the reciprocal of the condition number of a general real matrix A, in either the 1-norm or the infinity-norm, using the LU factorization computed by C. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as rcond = 1 / ( norm(A) * norm(inv(A)) ). Arguments ========= norm: Specifies whether the 1-norm condition number or the infinity-norm condition number is required: = 0: Infinity-norm. = 1: 1-norm; A: The factors L and U from the factorization A = P*L*U as computed by getrf. anorm: If norm = 0, the infinity-norm of the original matrix A. If norm = 1, the 1-norm of the original matrix A. rcond: The reciprocal of the condition number of the matrix A, computed as rcond = 1/(norm(A) * norm(inv(A))). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 100); $anorm = $a->lange(1); $ipiv = zeroes(long, 100); $info = null; getrf($a, $ipiv, $info); ($rcond, $info) = gecon($a, 1, $anorm) unless $info != 0; '); pp_def("sycon", HandleBad => 0, Pars => '[phys]A(n,n); int uplo(); int ipiv(n); [phys]anorm(); [o,phys]rcond();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int ssycon_(char *uplo, integer *n, float *a, integer * lda, integer *ipiv, float *anorm, float *rcond, float * work, integer *iwork, integer *info); float *work = (float *) malloc(($PRIV(__n_size) * 2) * sizeof(float)); %} types(D) %{ extern int dsycon_(char *uplo, integer *n, double *a, integer * lda, integer *ipiv, double *anorm, double *rcond, double * work, integer *iwork, integer *info); double *work = (double *) malloc(($PRIV(__n_size)*2) * sizeof(double)); %} integer *iwork = (integer *) malloc($PRIV(__n_size) * sizeof(integer)); if($uplo()) puplo = \'L\'; $TFD(ssycon_,dsycon_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ipiv), $P(anorm), $P(rcond), work, iwork, $P(info)); free (work); free(iwork); ', Doc => ' =for ref Estimates the reciprocal of the condition number (in the 1-norm) of a real symmetric matrix A using the factorization A = U*D*U\' or A = L*D*L\' computed by C. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as rcond = 1 / (anorm * norm(inv(A))). Arguments ========= uplo: Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 0: Upper triangular, form is A = U*D*U\'; = 1: Lower triangular, form is A = L*D*L\'. A: The block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by sytrf. ipiv: Details of the interchanges and the block structure of D as determined by sytrf. anorm: The 1-norm of the original matrix A. rcond: The reciprocal of the condition number of the matrix A, computed as rcond = 1/(anorm * aimvnm), where ainvnm is an estimate of the 1-norm of inv(A) computed in this routine. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. =for example # Assume $a is symmetric $a = random (float, 100, 100); $anorm = $a->lansy(1,1); $ipiv = zeroes(long, 100); $info = null; sytrf($a, 1,$ipiv, $info); ($rcond, $info) = sycon($a, 1, $anorm) unless $info != 0; '); pp_def("pocon", HandleBad => 0, Pars => '[phys]A(n,n); int uplo(); [phys]anorm(); [o,phys]rcond();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; types(F) %{ extern int spocon_(char *uplo, integer *n, float *a, integer * lda, float *anorm, float *rcond, float *work, integer * iwork, integer *info); float *work = (float *) malloc(($PRIV(__n_size) * 3) * sizeof(float)); %} types(D) %{ extern int dpocon_(char *uplo, integer *n, double *a, integer * lda, double *anorm, double *rcond, double *work, integer * iwork, integer *info); double *work = (double *) malloc(($PRIV(__n_size)*3) * sizeof(double)); %} integer *iwork = (integer *) malloc($PRIV(__n_size) * sizeof(integer)); if($uplo()) puplo = \'L\'; $TFD(spocon_,dpocon_)( &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(anorm), $P(rcond), work, iwork, $P(info)); free (work); free(iwork); ', Doc => ' =for ref Estimates the reciprocal of the condition number (in the 1-norm) of a real symmetric positive definite matrix using the Cholesky factorization A = U\'*U or A = L*L\' computed by C. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as rcond = 1 / (anorm * norm(inv(A))). Arguments ========= uplo: = 0: Upper triangle of A is stored; = 1: Lower triangle of A is stored. A: The triangular factor U or L from the Cholesky factorization A = U\'*U or A = L*L\', as computed by potrf. anorm: The 1-norm of the matrix A. rcond: The reciprocal of the condition number of the matrix A, computed as rcond = 1/(anorm * ainvnm), where ainvnm is an estimate of the 1-norm of inv(A) computed in this routine. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example # Assume $a is symmetric positive definite $a = random (float, 100, 100); $anorm = $a->lansy(1,1); $info = null; potrf($a, 0, $info); ($rcond, $info) = pocon($a, 1, $anorm) unless $info != 0; '); pp_def("trcon", HandleBad => 0, Pars => '[phys]A(n,n); int norm();int uplo();int diag(); [o,phys]rcond();int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char puplo = \'U\'; char pdiag = \'N\'; char pnorm = \'I\'; types(F) %{ extern int strcon_(char *norm, char *uplo, char *diag,integer *n, float *a, integer * lda, float *rcond, float *work, integer *iwork, integer *info); float *work = (float *) malloc(($PRIV(__n_size) * 3) * sizeof(float)); %} types(D) %{ extern int dtrcon_(char *norm, char *uplo, char *diag, integer *n, double *a, integer * lda, double *rcond, double * work, integer *iwork, integer *info); double *work = (double *) malloc(($PRIV(__n_size)*3) * sizeof(double)); %} integer *iwork = (integer *) malloc($PRIV(__n_size) * sizeof(integer)); if($uplo()) puplo = \'L\'; if($diag()) pdiag = \'U\'; if($norm()) pnorm = \'O\'; $TFD(strcon_,dtrcon_)( &pnorm, &puplo, &pdiag, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(rcond), work, iwork, $P(info)); free (work); free(iwork); ', Doc => ' =for ref Estimates the reciprocal of the condition number of a triangular matrix A, in either the 1-norm or the infinity-norm. The norm of A is computed and an estimate is obtained for norm(inv(A)), then the reciprocal of the condition number is computed as rcond = 1 / ( norm(A) * norm(inv(A)) ). Arguments ========= norm: Specifies whether the 1-norm condition number or the infinity-norm condition number is required: = 0: Infinity-norm. = 1: 1-norm; uplo: = 0: A is upper triangular; = 1: A is lower triangular. diag: = 0: A is non-unit triangular; = 1: A is unit triangular. A: The triangular matrix A. If uplo = 0, the leading N-by-N upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading N-by-N lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If diag = 1, the diagonal elements of A are also not referenced and are assumed to be 1. rcond: The reciprocal of the condition number of the matrix A, computed as rcond = 1/(norm(A) * norm(inv(A))). info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example # Assume $a is upper triangular $a = random (float, 100, 100); $info = null; ($rcond, $info) = trcon($a, 1, 1, 0) unless $info != 0; '); pp_def("geqp3", HandleBad => 0, Pars => '[io,phys]A(m,n); int [io,phys]jpvt(n); [o,phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sgeqp3_(integer *m, integer *n, float *a, integer * lda, integer *jpvt, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgeqp3_(integer *m, integer *n, double *a, integer * lda, integer *jpvt, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sgeqp3_,dgeqp3_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(jpvt), $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgeqp3_,dgeqp3_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(jpvt), $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref geqp3 computes a QR factorization using Level 3 BLAS with column pivoting of a matrix A: A*P = Q*R The matrix Q is represented as a product of elementary reflectors Q = H(1) H(2) . . . H(k), where k = min(m,n). Each H(i) has the form H(i) = I - tau * v * v\' where tau is a real/complex scalar, and v is a real/complex vector with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), and tau in tau(i). Arguments ========= A: On entry, the M-by-N matrix A. On exit, the upper triangle of the array contains the min(M,N)-by-N upper trapezoidal matrix R; the elements below the diagonal, together with the array tau, represent the orthogonal matrix Q as a product of min(M,N) elementary reflectors. jpvt: On entry, if jpvt(J)!=0, the J-th column of A is permuted to the front of A*P (a leading column); if jpvt(J)=0, the J-th column of A is a free column. On exit, if jpvt(J)=K, then the J-th column of A*P was the the K-th column of A. tau: The scalar factors of the elementary reflectors. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); $jpvt = zeroes(long, 50); geqp3($a, $jpvt, $tau, $info); '); pp_def("geqrf", HandleBad => 0, Pars => '[io,phys]A(m,n); [o,phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sgeqrf_(integer *m, integer *n, float *a, integer * lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgeqrf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sgeqrf_,dgeqrf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgeqrf_,dgeqrf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref geqrf computes a QR factorization of a matrix A: A = Q * R The matrix Q is represented as a product of elementary reflectors Q = H(1) H(2) . . . H(k), where k = min(m,n). Each H(i) has the form H(i) = I - tau * v * v\' where tau is a real/complex scalar, and v is a real/complex vector with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), and tau in tau(i). Arguments ========= A: On exit, the elements on and above the diagonal of the array contain the min(M,N)-by-N upper trapezoidal matrix R (R is upper triangular if m >= n); the elements below the diagonal, with the array TAU, represent the orthogonal matrix Q as a product of min(m,n) elementary reflectors. tau: The scalar factors of the elementary reflectors. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); geqrf($a, $tau, $info); '); pp_def("orgqr", HandleBad => 0, Pars => '[io,phys]A(m,n); [phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sorgqr_(integer *m, integer *n, integer *k, float * a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dorgqr_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sorgqr_,dorgqr_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sorgqr_,dorgqr_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Generates an M-by-N real matrix Q with orthonormal columns, which is defined as the first N columns of a product of K elementary reflectors of order M Q = H(1) H(2) . . . H(k) as returned by geqrf or geqp3. Arguments ========= A: On entry, the i-th column must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by geqrf or geqp3 in the first k columns of its array argument A. On exit, the M-by-N matrix Q. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by geqrf or geqp3. info: = 0: successful exit < 0: if info = -i, the i-th argument has an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); geqrf($a, $tau, $info); orgqr($a, $tau, $info) unless $info != 0; '); pp_def("ormqr", HandleBad => 0, Pars => '[phys]A(p,k); int side(); int trans(); [phys]tau(k); [io,phys]C(m,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\', pside = \'L\'; integer lwork = -1; types(F) %{ extern int sormqr_(char *side, char *trans, integer *m, integer *n, integer *k, float *a, integer *lda, float *tau, float * c__, integer *ldc, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dormqr_(char *side, char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); double tmp_work; %} if($trans()) ptrans = \'T\'; if($side()) pside = \'R\'; $TFD(sormqr_,dormqr_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__p_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sormqr_,dormqr_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__p_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Overwrites the general real M-by-N matrix C with side = 0 side = 1 trans = 0: Q * C C * Q trans = 1: Q\' * C C * Q\' where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(1) H(2) . . . H(k) as returned by geqrf or geqp3. Q is of order M if C = 0 and of order N if C = 1. Arguments ========= side: = 0: apply Q or Q\' from the Left; = 1: apply Q or Q\' from the Right. trans: = 0: No transpose, apply Q; = 1: Transpose, apply Q\'. A: The i-th column must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by geqrf or geqp3 in the first k columns of its array argument A. A is modified by the routine but restored on exit. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by geqrf or geqp3. C: On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q\'*C or C*Q\' or C*Q. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $a = transpose($a); $info = null; $tau = zeroes(float, 50); geqrf($a, $tau, $info); $c = random(70,50); # $c will contain the result $c->reshape(70,100); $c = transpose($c); ormqr($a, $tau, $c, $info); '); pp_def("gelqf", HandleBad => 0, Pars => '[io,phys]A(m,n); [o,phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sgelqf_(integer *m, integer *n, float *a, integer * lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgelqf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sgelqf_,dgelqf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgelqf_,dgelqf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes an LQ factorization of a real M-by-N matrix A: A = L * Q. The matrix Q is represented as a product of elementary reflectors Q = H(k) . . . H(2) H(1), where k = min(m,n). Each H(i) has the form H(i) = I - tau * v * v\' where tau is a real scalar, and v is a real vector with v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), and tau in tau(i). Arguments ========= A: On entry, the M-by-N matrix A. On exit, the elements on and below the diagonal of the array contain the m-by-min(m,n) lower trapezoidal matrix L (L is lower triangular if m <= n); the elements above the diagonal, with the array tau, represent the orthogonal matrix Q as a product of elementary reflectors. tau: The scalar factors of the elementary reflectors. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); gelqf($a, $tau, $info); '); pp_def("orglq", HandleBad => 0, Pars => '[io,phys]A(m,n); [phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sorglq_(integer *m, integer *n, integer *k, float * a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dorglq_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sorglq_,dorglq_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sorglq_,dorglq_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Generates an M-by-N real matrix Q with orthonormal rows, which is defined as the first M rows of a product of K elementary reflectors of order N Q = H(k) . . . H(2) H(1) as returned by gelqf. Arguments ========= A: On entry, the i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by gelqf in the first k rows of its array argument A. On exit, the M-by-N matrix Q. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by gelqf. info: = 0: successful exit < 0: if info = -i, the i-th argument has an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); gelqf($a, $tau, $info); orglq($a, $tau, $info) unless $info != 0; '); pp_def("ormlq", HandleBad => 0, Pars => '[phys]A(k,p); int side(); int trans(); [phys]tau(k); [io,phys]C(m,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\', pside = \'L\'; integer lwork = -1; types(F) %{ extern int sormlq_(char *side, char *trans, integer *m, integer *n, integer *k, float *a, integer *lda, float *tau, float * c__, integer *ldc, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dormlq_(char *side, char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); double tmp_work; %} if($trans()) ptrans = \'T\'; if($side()) pside = \'R\'; $TFD(sormlq_,dormlq_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sormlq_,dormlq_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Overwrites the general real M-by-N matrix C with side = 0 side = 1 trans = 0: Q * C C * Q trans = 1: Q\' * C C * Q\' where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(k) . . . H(2) H(1) as returned by gelqf. Q is of order M if C = 0 and of order N if C = 1. Arguments ========= side: = 0: apply Q or Q\' from the Left; = 1: apply Q or Q\' from the Right. trans: = 0: No transpose, apply Q; = 1: Transpose, apply Q\'. A: The i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by gelqf in the first k rows of its array argument A. A is modified by the routine but restored on exit. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by gelqf. C: On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q\'*C or C*Q\' or C*Q. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $a = transpose($a); $info = null; $tau = zeroes(float, 50); gelqf($a, $tau, $info); $c = random(70,50); # $c will contain the result $c->reshape(70,100); $c = transpose($c); ormlq($a, $tau, $c, $info); '); pp_def("geqlf", HandleBad => 0, Pars => '[io,phys]A(m,n); [o,phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sgeqlf_(integer *m, integer *n, float *a, integer * lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgeqlf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sgeqlf_,dgeqlf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgeqlf_,dgeqlf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes a QL factorization of a real M-by-N matrix A: A = Q * L The matrix Q is represented as a product of elementary reflectors Q = H(k) . . . H(2) H(1), where k = min(m,n). Each H(i) has the form H(i) = I - tau * v * v\' where tau is a real scalar, and v is a real vector with v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in A(1:m-k+i-1,n-k+i), and tau in TAU(i). Arguments ========= A: On entry, the M-by-N matrix A. On exit, if m >= n, the lower triangle of the subarray A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; if m <= n, the elements on and below the (n-m)-th superdiagonal contain the M-by-N lower trapezoidal matrix L; the remaining elements, with the array tau, represent the orthogonal matrix Q as a product of elementary reflectors. tau: The scalar factors of the elementary reflectors. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); geqlf($a, $tau, $info); '); pp_def("orgql", HandleBad => 0, Pars => '[io,phys]A(m,n); [phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sorgql_(integer *m, integer *n, integer *k, float * a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dorgql_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sorgql_,dorgql_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sorgql_,dorgql_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Generates an M-by-N real matrix Q with orthonormal columns, which is defined as the last N columns of a product of K elementary reflectors of order M Q = H(k) . . . H(2) H(1) as returned by geqlf. Arguments ========= A: On entry, the (n-k+i)-th column must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by geqlf in the last k columns of its array argument A. On exit, the M-by-N matrix Q. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by geqlf. info: = 0: successful exit < 0: if info = -i, the i-th argument has an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); geqlf($a, $tau, $info); orgql($a, $tau, $info) unless $info != 0; '); pp_def("ormql", HandleBad => 0, Pars => '[phys]A(p,k); int side(); int trans(); [phys]tau(k); [io,phys]C(m,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\', pside = \'L\'; integer lwork = -1; types(F) %{ extern int sormql_(char *side, char *trans, integer *m, integer *n, integer *k, float *a, integer *lda, float *tau, float * c__, integer *ldc, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dormql_(char *side, char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); double tmp_work; %} if($trans()) ptrans = \'T\'; if($side()) pside = \'R\'; $TFD(sormql_,dormql_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__p_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sormql_,dormql_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__p_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Overwrites the general real M-by-N matrix C with side = 0 side = 1 trans = 0: Q * C C * Q trans = 1: Q\' * C C * Q\' where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(k) . . . H(2) H(1) as returned by geqlf. Q is of order M if C = 0 and of order N if C = 1. Arguments ========= side: = 0: apply Q or Q\' from the Left; = 1: apply Q or Q\' from the Right. trans: = 0: No transpose, apply Q; = 1: Transpose, apply Q\'. A: The i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by geqlf in the last k rows of its array argument A. A is modified by the routine but restored on exit. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by geqlf. C: On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q\'*C or C*Q\' or C*Q. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $a = transpose($a); $info = null; $tau = zeroes(float, 50); geqlf($a, $tau, $info); $c = random(70,50); # $c will contain the result $c->reshape(70,100); $c = transpose($c); ormql($a, $tau, $c, $info); '); pp_def("gerqf", HandleBad => 0, Pars => '[io,phys]A(m,n); [o,phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sgerqf_(integer *m, integer *n, float *a, integer * lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgerqf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sgerqf_,dgerqf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgerqf_,dgerqf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes an RQ factorization of a real M-by-N matrix A: A = R * Q. The matrix Q is represented as a product of elementary reflectors Q = H(1) H(2) . . . H(k), where k = min(m,n). Each H(i) has the form H(i) = I - tau * v * v\' where tau is a real scalar, and v is a real vector with v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). Arguments ========= A: On entry, the M-by-N matrix A. On exit, if m <= n, the upper triangle of the subarray A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; if m >= n, the elements on and above the (m-n)-th subdiagonal contain the M-by-N upper trapezoidal matrix R; the remaining elements, with the array tau, represent the orthogonal matrix Q as a product of min(m,n) elementary reflectors (see Further Details). tau: The scalar factors of the elementary reflectors. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); gerqf($a, $tau, $info); '); pp_def("orgrq", HandleBad => 0, Pars => '[io,phys]A(m,n); [phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sorgrq_(integer *m, integer *n, integer *k, float * a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dorgrq_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sorgrq_,dorgrq_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sorgrq_,dorgrq_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Generates an M-by-N real matrix Q with orthonormal rows, which is defined as the last M rows of a product of K elementary reflectors of order N Q = H(1) H(2) . . . H(k) as returned by gerqf. Arguments ========= A: On entry, the (m-k+i)-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by gerqf in the last k rows of its array argument A. On exit, the M-by-N matrix Q. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by gerqf. info: = 0: successful exit < 0: if info = -i, the i-th argument has an illegal value =for example $a = random (float, 100, 50); $info = null; $tau = zeroes(float, 50); gerqf($a, $tau, $info); orgrq($a, $tau, $info) unless $info != 0; '); pp_def("ormrq", HandleBad => 0, Pars => '[phys]A(k,p); int side(); int trans(); [phys]tau(k); [io,phys]C(m,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\', pside = \'L\'; integer lwork = -1; types(F) %{ extern int sormrq_(char *side, char *trans, integer *m, integer *n, integer *k, float *a, integer *lda, float *tau, float * c__, integer *ldc, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dormrq_(char *side, char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); double tmp_work; %} if($trans()) ptrans = \'T\'; if($side()) pside = \'R\'; $TFD(sormrq_,dormrq_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sormrq_,dormrq_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Overwrites the general real M-by-N matrix C with side = 0 side = 1 trans = 0: Q * C C * Q trans = 1: Q\' * C C * Q\' where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(1) H(2) . . . H(k) as returned by gerqf. Q is of order M if C = 0 and of order N if C = 1. Arguments ========= side: = 0: apply Q or Q\' from the Left; = 1: apply Q or Q\' from the Right. trans: = 0: No transpose, apply Q; = 1: Transpose, apply Q\'. A: The i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by gerqf in the last k rows of its array argument A. A is modified by the routine but restored on exit. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by gerqf. C: On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q\'*C or C*Q\' or C*Q. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $a = transpose($a); $info = null; $tau = zeroes(float, 50); gerqf($a, $tau, $info); $c = random(70,50); # $c will contain the result $c->reshape(70,100); $c = transpose($c); ormrq($a, $tau, $c, $info); '); pp_def("tzrzf", HandleBad => 0, Pars => '[io,phys]A(m,n); [o,phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int stzrzf_(integer *m, integer *n, float *a, integer * lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dtzrzf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(stzrzf_,dtzrzf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(stzrzf_,dtzrzf_)( &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Reduces the M-by-N ( M <= N ) real upper trapezoidal matrix A to upper triangular form by means of orthogonal transformations. The upper trapezoidal matrix A is factored as A = ( R 0 ) * Z, where Z is an N-by-N orthogonal matrix and R is an M-by-M upper triangular matrix. The factorization is obtained by Householder\'s method. The kth transformation matrix, Z( k ), which is used to introduce zeros into the ( m - k + 1 )th row of A, is given in the form Z( k ) = ( I 0 ), ( 0 T( k ) ) where T( k ) = I - tau*u( k )*u( k )\', u( k ) = ( 1 ), ( 0 ) ( z( k ) ) tau is a scalar and z( k ) is an ( n - m ) element vector. tau and z( k ) are chosen to annihilate the elements of the kth row of X. The scalar tau is returned in the kth element of C and the vector u( k ) in the kth row of A, such that the elements of z( k ) are in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in the upper triangular part of A. Z is given by Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). Arguments ========= A: On entry, the leading M-by-N upper trapezoidal part of the array A must contain the matrix to be factorized. On exit, the leading M-by-M upper triangular part of A contains the upper triangular matrix R, and elements M+1 to N of the first M rows of A, with the array tau, represent the orthogonal matrix Z as a product of M elementary reflectors. tau: The scalar factors of the elementary reflectors. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $info = null; $tau = zeroes(float, 50); tzrzf($a, $tau, $info); '); pp_def("ormrz", HandleBad => 0, Pars => '[phys]A(k,p); int side(); int trans(); [phys]tau(k); [io,phys]C(m,n);int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char ptrans = \'N\', pside = \'L\'; integer lwork = -1; integer kk = $SIZE(p) - $SIZE(k); types(F) %{ extern int sormrz_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, float *a, integer *lda, float *tau, float * c__, integer *ldc, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dormrz_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); double tmp_work; %} if($trans()) ptrans = \'T\'; if($side()) pside = \'R\'; $TFD(sormrz_,dormrz_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, &kk, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sormrz_,dormrz_)( &pside, &ptrans, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__k_size)}, &kk, $P(A), &(integer){$PRIV(__k_size)}, $P(tau), $P(C), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Overwrites the general real M-by-N matrix C with side = 0 side = 1 trans = 0: Q * C C * Q trans = 1: Q\' * C C * Q\' where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(1) H(2) . . . H(k) as returned by tzrzf. Q is of order M if C = 0 and of order N if C = 1. Arguments ========= side: = 0: apply Q or Q\' from the Left; = 1: apply Q or Q\' from the Right. trans: = 0: No transpose, apply Q; = 1: Transpose, apply Q\'. A: The i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by tzrzf in the last k rows of its array argument A. A is modified by the routine but restored on exit. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by tzrzf. C: On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q\'*C or C*Q\' or C*Q. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (float, 50, 100); $a = transpose($a); $info = null; $tau = zeroes(float, 50); tzrzf($a, $tau, $info); $c = random(70,50); # $c will contain the result $c->reshape(70,100); $c = transpose($c); ormrz($a, $tau, $c, $info); '); pp_def("gehrd", HandleBad => 0, Pars => '[io,phys]A(n,n); int [phys]ilo();int [phys]ihi();[o,phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sgehrd_(integer *n, integer *ilo, integer *ihi, float *a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dgehrd_(integer *n, integer *ilo, integer *ihi, double *a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sgehrd_,dgehrd_)( &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(A), &(integer){$PRIV(__n_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sgehrd_,dgehrd_)( &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(A), &(integer){$PRIV(__n_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Reduces a real general matrix A to upper Hessenberg form H by an orthogonal similarity transformation: Q\' * A * Q = H . Further Details =============== The matrix Q is represented as a product of (ihi-ilo) elementary reflectors Q = H(ilo) H(ilo+1) . . . H(ihi-1). Each H(i) has the form H(i) = I - tau * v * v\' where tau is a real scalar, and v is a real vector with v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on exit in A(i+2:ihi,i), and tau in tau(i). The contents of A are illustrated by the following example, with n = 7, ilo = 2 and ihi = 6: on entry, on exit, ( a a a a a a a ) ( a a h h h h a ) ( a a a a a a ) ( a h h h h a ) ( a a a a a a ) ( h h h h h h ) ( a a a a a a ) ( v2 h h h h h ) ( a a a a a a ) ( v2 v3 h h h h ) ( a a a a a a ) ( v2 v3 v4 h h h ) ( a ) ( a ) where a denotes an element of the original matrix A, h denotes a modified element of the upper Hessenberg matrix H, and vi denotes an element of the vector defining H(i). Arguments ========= ilo: ihi: It is assumed that A is already upper triangular in rows and columns 1:ilo-1 and ihi+1:N. ilo and ihi are normally set by a previous call to gebal; otherwise they should be set to 1 and N respectively. See Further Details. 1 <= ilo <= ihi <= N, if N > 0; ilo=1 and ihi=0, if N=0. A: On entry, the N-by-N general matrix to be reduced. On exit, the upper triangle and the first subdiagonal of A are overwritten with the upper Hessenberg matrix H, and the elements below the first subdiagonal, with the array tau, represent the orthogonal matrix Q as a product of elementary reflectors. See Further Details. tau: The scalar factors of the elementary reflectors (see Further Details). Elements 1:ilo-1 and ihi:N-1 of tau are set to zero. (dimension (N-1)) info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random (50, 50); $info = null; $tau = zeroes(50); gehrd($a, 1, 50, $tau, $info); '); pp_def("orghr", HandleBad => 0, Pars => '[io,phys]A(n,n); int [phys]ilo();int [phys]ihi();[phys]tau(k); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' integer lwork = -1; types(F) %{ extern int sorghr_(integer *n, integer *ilo, integer *ihi, float *a, integer *lda, float *tau, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dorghr_(integer *n, integer *ilo, integer *ihi, double *a, integer *lda, double *tau, double *work, integer *lwork, integer *info); double tmp_work; %} $TFD(sorghr_,dorghr_)( &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(A), &(integer){$PRIV(__n_size)}, $P(tau), &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(sorghr_,dorghr_)( &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(A), &(integer){$PRIV(__n_size)}, $P(tau), work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Generates a real orthogonal matrix Q which is defined as the product of ihi-ilo elementary reflectors of order N, as returned by C: Q = H(ilo) H(ilo+1) . . . H(ihi-1). Arguments ========= ilo: ihi: ilo and ihi must have the same values as in the previous call of gehrd. Q is equal to the unit matrix except in the submatrix Q(ilo+1:ihi,ilo+1:ihi). 1 <= ilo <= ihi <= N, if N > 0; ilo=1 and ihi=0, if N=0. A: On entry, the vectors which define the elementary reflectors, as returned by gehrd. On exit, the N-by-N orthogonal matrix Q. tau: tau(i) must contain the scalar factor of the elementary reflector H(i), as returned by gehrd.(dimension (N-1)) info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (50, 50); $info = null; $tau = zeroes(50); gehrd($a, 1, 50, $tau, $info); orghr($a, 1, 50, $tau, $info); '); pp_def("hseqr", HandleBad => 0, Pars => '[io,phys]H(n,n); int job();int compz();int [phys]ilo();int [phys]ihi();[o,phys]wr(n); [o,phys]wi(n);[o,phys]Z(m,m); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pcompz; char pjob = \'E\'; integer lwork = -1; types(F) %{ extern int shseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, float *h__, integer *ldh, float *wr, float *wi, float *z__, integer *ldz, float *work, integer *lwork, integer *info); float tmp_work; %} types(D) %{ extern int dhseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, double *h__, integer *ldh, double *wr, double *wi, double *z__, integer *ldz, double *work, integer *lwork, integer *info); double tmp_work; %} if($job()) pjob = \'S\'; switch ($compz()) { case 1: pcompz = \'I\'; break; case 2: pcompz = \'V\'; break; default: pcompz = \'N\'; } $TFD(shseqr_,dhseqr_)( &pjob, &pcompz, &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(H), &(integer){$PRIV(__n_size)}, $P(wr), $P(wi), $P(Z), &(integer){$PRIV(__m_size)}, &tmp_work, &lwork, $P(info)); lwork = (integer )tmp_work; { types(F) %{ float *work = (float *)malloc(lwork * sizeof(float)); %} types(D) %{ double *work = (double *)malloc(lwork * sizeof(double)); %} $TFD(shseqr_,dhseqr_)( &pjob, &pcompz, &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(H), &(integer){$PRIV(__n_size)}, $P(wr), $P(wi), $P(Z), &(integer){$PRIV(__m_size)}, work, &lwork, $P(info)); free(work); } ', Doc => ' =for ref Computes the eigenvalues of a real upper Hessenberg matrix H and, optionally, the matrices T and Z from the Schur decomposition H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur form), and Z is the orthogonal matrix of Schur vectors. Optionally Z may be postmultiplied into an input orthogonal matrix Q, so that this routine can give the Schur factorization of a matrix A which has been reduced to the Hessenberg form H by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. Arguments ========= job: = 0: compute eigenvalues only; = 1: compute eigenvalues and the Schur form T. compz: = 0: no Schur vectors are computed; = 1: Z is initialized to the unit matrix and the matrix Z of Schur vectors of H is returned; = 2: Z must contain an orthogonal matrix Q on entry, and the product Q*Z is returned. ilo: ihi: It is assumed that H is already upper triangular in rows and columns 1:ilo-1 and ihi+1:N. ilo and ihi are normally set by a previous call to gebal, and then passed to gehrd when the matrix output by gebal is reduced to Hessenberg form. Otherwise ilo and ihi should be set to 1 and N respectively. 1 <= ilo <= ihi <= N, if N > 0; ilo=1 and ihi=0, if N=0. H: On entry, the upper Hessenberg matrix H. On exit, if job = 1, H contains the upper quasi-triangular matrix T from the Schur decomposition (the Schur form); 2-by-2 diagonal blocks (corresponding to complex conjugate pairs of eigenvalues) are returned in standard form, with H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If job = 0, the contents of H are unspecified on exit. wr: wi: The real and imaginary parts, respectively, of the computed eigenvalues. If two eigenvalues are computed as a complex conjugate pair, they are stored in consecutive elements of wr and wi, say the i-th and (i+1)th, with wi(i) > 0 and wi(i+1) < 0. If job = 1, the eigenvalues are stored in the same order as on the diagonal of the Schur form returned in H, with wr(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal block, wi(i) = sqrt(H(i+1,i)*H(i,i+1)) and wi(i+1) = -wi(i). Z: If compz = 0: Z is not referenced. If compz = 1: on entry, Z need not be set, and on exit, Z contains the orthogonal matrix Z of the Schur vectors of H. If compz = 2: on entry Z must contain an N-by-N matrix Q, which is assumed to be equal to the unit matrix except for the submatrix Z(ilo:ihi,ilo:ihi); on exit Z contains Q*Z. Normally Q is the orthogonal matrix generated by orghr after the call to gehrd which formed the Hessenberg matrix H. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value > 0: if info = i, hseqr failed to compute all of the eigenvalues in a total of 30*(ihi-ilo+1) iterations; elements 1:ilo-1 and i+1:n of wr and wi contain those eigenvalues which have been successfully computed. =for example $a = random (50, 50); $info = null; $tau = zeroes(50); $z= zeroes(1,1); gehrd($a, 1, 50, $tau, $info); hseqr($a,0,0,1,50,($wr=null),($wi=null),$z,$info); '); pp_def("trevc", HandleBad => 0, Pars => '[io,phys]T(n,n); int side();int howmny();int [phys]select(q);[io,phys]VL(m,r); [io,phys]VR(p,s);int [o,phys]m(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pside,phowmny; integer mm = 0; types(F) %{ extern int strevc_(char *side, char *howmny, logical *select, integer *n, float *t, integer *ldt, float *vl, integer * ldvl, float *vr, integer *ldvr, integer *mm, integer *m, float *work, integer *info); float *work = (float *) malloc(3* $SIZE(n) *sizeof(float)); %} types(D) %{ extern int dtrevc_(char *side, char *howmny, logical *select, integer *n, double *t, integer *ldt, double *vl, integer * ldvl, double *vr, integer *ldvr, integer *mm, integer *m, double *work, integer *info); double *work = (double *) malloc (3 * $SIZE(n) * sizeof(double)); %} switch ($howmny()) { case 1: phowmny = \'B\'; break; case 2: phowmny = \'S\'; break; default: phowmny = \'A\'; } switch ($side()) { case 1: pside = \'R\'; mm = $SIZE(s); break; case 2: pside = \'L\'; mm = $SIZE(r); break; default:pside = \'B\'; mm = $SIZE(s); } $TFD(strevc_,dtrevc_)( &pside, &phowmny, $P(select), &(integer){$PRIV(__n_size)}, $P(T), &(integer){$PRIV(__n_size)}, $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, &mm, $P(m), work, $P(info)); free(work); ', Doc => ' =for ref Computes some or all of the right and/or left eigenvectors of a real upper quasi-triangular matrix T. The right eigenvector x and the left eigenvector y of T corresponding to an eigenvalue w are defined by: T*x = w*x, y\'*T = w*y\' where y\' denotes the conjugate transpose of the vector y. If all eigenvectors are requested, the routine may either return the matrices X and/or Y of right or left eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an input orthogonal matrix. If T was obtained from the real-Schur factorization of an original matrix A = Q*T*Q\', then Q*X and Q*Y are the matrices of right or left eigenvectors of A. T must be in Schur canonical form (as returned by hseqr), that is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its diagonal elements equal and its off-diagonal elements of opposite sign. Corresponding to each 2-by-2 diagonal block is a complex conjugate pair of eigenvalues and eigenvectors; only one eigenvector of the pair is computed, namely the one corresponding to the eigenvalue with positive imaginary part. Further Details =============== The algorithm used in this program is basically backward (forward) substitution, with scaling to make the the code robust against possible overflow. Each eigenvector is normalized so that the element of largest magnitude has magnitude 1; here the magnitude of a complex number (x,y) is taken to be |x| + |y|. Arguments ========= side: = 0 : compute both right and left eigenvectors; = 1 : compute right eigenvectors only; = 2 : compute left eigenvectors only. howmny: = 0: compute all right and/or left eigenvectors; = 1: compute all right and/or left eigenvectors, and backtransform them using the input matrices supplied in VR and/or VL; = 2: compute selected right and/or left eigenvectors, specified by the logical array select. select: If howmny = 2, select specifies the eigenvectors to be computed. If howmny = 0 or 1, select is not referenced. To select the real eigenvector corresponding to a real eigenvalue w(j), select(j) must be set to TRUE. To select the complex eigenvector corresponding to a complex conjugate pair w(j) and w(j+1), either select(j) or select(j+1) must be set to TRUE; then on exit select(j) is TRUE and select(j+1) is FALSE. T: The upper quasi-triangular matrix T in Schur canonical form. VL: On entry, if side = 2 or 0 and howmny = 1, VL must contain an N-by-N matrix Q (usually the orthogonal matrix Q of Schur vectors returned by hseqr). On exit, if side = 2 or 0, VL contains: if howmny = 0, the matrix Y of left eigenvectors of T; VL has the same quasi-lower triangular form as T\'. If T(i,i) is a real eigenvalue, then the i-th column VL(i) of VL is its corresponding eigenvector. If T(i:i+1,i:i+1) is a 2-by-2 block whose eigenvalues are complex-conjugate eigenvalues of T, then VL(i)+sqrt(-1)*VL(i+1) is the complex eigenvector corresponding to the eigenvalue with positive real part. if howmny = 1, the matrix Q*Y; if howmny = 2, the left eigenvectors of T specified by select, stored consecutively in the columns of VL, in the same order as their eigenvalues. A complex eigenvector corresponding to a complex eigenvalue is stored in two consecutive columns, the first holding the real part, and the second the imaginary part. If side = 1, VL is not referenced. VR: On entry, if side = 1 or 0 and howmny = 1, VR must contain an N-by-N matrix Q (usually the orthogonal matrix Q of Schur vectors returned by hseqr). On exit, if side = 1 or 0, VR contains: if howmny = 0, the matrix X of right eigenvectors of T; VR has the same quasi-upper triangular form as T. If T(i,i) is a real eigenvalue, then the i-th column VR(i) of VR is its corresponding eigenvector. If T(i:i+1,i:i+1) is a 2-by-2 block whose eigenvalues are complex-conjugate eigenvalues of T, then VR(i)+sqrt(-1)*VR(i+1) is the complex eigenvector corresponding to the eigenvalue with positive real part. if howmny = 1, the matrix Q*X; if howmny = 2, the right eigenvectors of T specified by select, stored consecutively in the columns of VR, in the same order as their eigenvalues. A complex eigenvector corresponding to a complex eigenvalue is stored in two consecutive columns, the first holding the real part and the second the imaginary part. If side = 2, VR is not referenced. m: The number of columns in the arrays VL and/or VR actually used to store the eigenvectors. If howmny = 0 or 1, m is set to N. Each selected real eigenvector occupies one column and each selected complex eigenvector occupies two columns. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random (50, 50); $info = null; $tau = zeroes(50); $z= zeroes(1,1); gehrd($a, 1, 50, $tau, $info); hseqr($a,0,0,1,50,($wr=null),($wi=null),$z,$info); '); pp_def("tgevc", HandleBad => 0, Pars => '[io,phys]A(n,n); int side();int howmny();[io,phys]B(n,n);int [phys]select(q);[io,phys]VL(m,r); [io,phys]VR(p,s);int [o,phys]m(); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pside,phowmny; integer mm = 0; types(F) %{ extern int stgevc_(char *side, char *howmny, logical *select, integer *n, float *a, integer *lda, float *b,integer *ldb, float *vl, integer *ldvl, float *vr, integer *ldvr, integer *mm, integer *m, float *work, integer *info); float *work = (float *) malloc(6* $SIZE(n) *sizeof(float)); %} types(D) %{ extern int dtgevc_(char *side, char *howmny, logical *select, integer *n, double *a, integer *lda, double *b, integer *ldb, double *vl, integer *ldvl, double *vr, integer *ldvr, integer *mm, integer *m, double *work, integer *info); double *work = (double *) malloc (6 * $SIZE(n) * sizeof(double)); %} switch ($howmny()) { case 1: phowmny = \'B\'; break; case 2: phowmny = \'S\'; break; default: phowmny = \'A\'; } switch ($side()) { case 1: pside = \'R\'; mm = $SIZE(s); break; case 2: pside = \'L\'; mm = $SIZE(r); break; default:pside = \'B\'; mm = $SIZE(s); } $TFD(stgevc_,dtgevc_)( &pside, &phowmny, $P(select), &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(B), &(integer){$PRIV(__n_size)}, $P(VL), &(integer){$PRIV(__m_size)}, $P(VR), &(integer){$PRIV(__p_size)}, &mm, $P(m), work, $P(info)); free(work); ', Doc => ' =for ref Computes some or all of the right and/or left generalized eigenvectors of a pair of real upper triangular matrices (A,B). The right generalized eigenvector x and the left generalized eigenvector y of (A,B) corresponding to a generalized eigenvalue w are defined by: (A - wB) * x = 0 and y**H * (A - wB) = 0 where y**H denotes the conjugate tranpose of y. If an eigenvalue w is determined by zero diagonal elements of both A and B, a unit vector is returned as the corresponding eigenvector. If all eigenvectors are requested, the routine may either return the matrices X and/or Y of right or left eigenvectors of (A,B), or the products Z*X and/or Q*Y, where Z and Q are input orthogonal matrices. If (A,B) was obtained from the generalized real-Schur factorization of an original pair of matrices (A0,B0) = (Q*A*Z**H,Q*B*Z**H), then Z*X and Q*Y are the matrices of right or left eigenvectors of A. A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal blocks. Corresponding to each 2-by-2 diagonal block is a complex conjugate pair of eigenvalues and eigenvectors; only one eigenvector of the pair is computed, namely the one corresponding to the eigenvalue with positive imaginary part. Arguments ========= side: = 0 : compute both right and left eigenvectors; = 1 : compute right eigenvectors only; = 2 : compute left eigenvectors only. howmny: = 0 : compute all right and/or left eigenvectors; = 1 : compute all right and/or left eigenvectors, and backtransform them using the input matrices supplied in VR and/or VL; = 2 : compute selected right and/or left eigenvectors, specified by the logical array select. select: If howmny=2, select specifies the eigenvectors to be computed. If howmny=0 or 1, select is not referenced. To select the real eigenvector corresponding to the real eigenvalue w(j), select(j) must be set to TRUE To select the complex eigenvector corresponding to a complex conjugate pair w(j) and w(j+1), either select(j) or select(j+1) must be set to TRUE. A: The upper quasi-triangular matrix A. B: The upper triangular matrix B. If A has a 2-by-2 diagonal block, then the corresponding 2-by-2 block of B must be diagonal with positive elements. VL: On entry, if side = 2 or 0 and howmny = 1, VL must contain an N-by-N matrix Q (usually the orthogonal matrix Q of left Schur vectors returned by hgqez). On exit, if side = 2 or 0, VL contains: if howmny = 0, the matrix Y of left eigenvectors of (A,B); if howmny = 1, the matrix Q*Y; if howmny = 2, the left eigenvectors of (A,B) specified by select, stored consecutively in the columns of VL, in the same order as their eigenvalues. If side = 1, VL is not referenced. A complex eigenvector corresponding to a complex eigenvalue is stored in two consecutive columns, the first holding the real part, and the second the imaginary part. VR: On entry, if side = 1 or 0 and howmny = 1, VR must contain an N-by-N matrix Q (usually the orthogonal matrix Z of right Schur vectors returned by hgeqz). On exit, if side = 1 or 0, VR contains: if howmny = 0, the matrix X of right eigenvectors of (A,B); if howmny = 1, the matrix Z*X; if howmny = 2, the right eigenvectors of (A,B) specified by select, stored consecutively in the columns of VR, in the same order as their eigenvalues. If side = 2, VR is not referenced. A complex eigenvector corresponding to a complex eigenvalue is stored in two consecutive columns, the first holding the real part and the second the imaginary part. M: The number of columns in the arrays VL and/or VR actually used to store the eigenvectors. If howmny = 0 or 1, M is set to N. Each selected real eigenvector occupies one column and each selected complex eigenvector occupies two columns. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. > 0: the 2-by-2 block (info:info+1) does not have a complex eigenvalue. =for example $a = random (50, 50); $info = null; $tau = zeroes(50); $z= zeroes(1,1); gehrd($a, 1, 50, $tau, $info); hseqr($a,0,0,1,50,($wr=null),($wi=null),$z,$info); '); pp_def("gebal", HandleBad => 0, Pars => '[io,phys]A(n,n); int job(); int [o,phys]ilo();int [o,phys]ihi();[o,phys]scale(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pjob; types(F) %{ extern int sgebal_(char *job, integer *n, float *a, integer * lda, integer *ilo, integer *ihi, float *scale, integer *info); %} types(D) %{ extern int dgebal_(char *job, integer *n, double *a, integer * lda, integer *ilo, integer *ihi, double *scale, integer *info); %} switch ($job()) { case 1: pjob = \'P\'; break; case 2: pjob = \'S\'; break; case 3: pjob = \'B\'; break; default: pjob = \'N\'; } $TFD(sgebal_,dgebal_)( &pjob, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(scale), $P(info)); ', Doc => ' =for ref Balances a general real matrix A. This involves, first, permuting A by a similarity transformation to isolate eigenvalues in the first 1 to ilo-1 and last ihi+1 to N elements on the diagonal; and second, applying a diagonal similarity transformation to rows and columns ilo to ihi to make the rows and columns as close in norm as possible. Both steps are optional. Balancing may reduce the 1-norm of the matrix, and improve the accuracy of the computed eigenvalues and/or eigenvectors. Further Details =============== The permutations consist of row and column interchanges which put the matrix in the form ( T1 X Y ) P A P = ( 0 B Z ) ( 0 0 T2 ) where T1 and T2 are upper triangular matrices whose eigenvalues lie along the diagonal. The column indices ilo and ihi mark the starting and ending columns of the submatrix B. Balancing consists of applying a diagonal similarity transformation inv(D) * B * D to make the 1-norms of each row of B and its corresponding column nearly equal. The output matrix is ( T1 X*D Y ) ( 0 inv(D)*B*D inv(D)*Z ). ( 0 0 T2 ) Information about the permutations P and the diagonal matrix D is returned in the vector C. Arguments ========= job: Specifies the operations to be performed on A: = 0: none: simply set ilo = 1, ihi = N, scale(I) = 1.0 for i = 1,...,N; = 1: permute only; = 2: scale only; = 3: both permute and scale. A: On entry, the input matrix A. On exit, A is overwritten by the balanced matrix. If job = 0, A is not referenced. See Further Details. ilo: ihi: ilo and ihi are set to integers such that on exit A(i,j) = 0 if i > j and j = 1,...,ilo-1 or I = ihi+1,...,N. If job = 0 or 2, ilo = 1 and ihi = N. scale: Details of the permutations and scaling factors applied to A. If P(j) is the index of the row and column interchanged with row and column j and D(j) is the scaling factor applied to row and column j, then scale(j) = P(j) for j = 1,...,ilo-1 = D(j) for j = ilo,...,ihi = P(j) for j = ihi+1,...,N. The order in which the interchanges are made is N to ihi+1, then 1 to ilo-1. info: = 0: successful exit. < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random (50, 50); $scale = zeroes(50); $info = null; $ilo = null; $ihi = null; gebal($a, $ilo, $ihi, $scale, $info); '); pp_def("gebak", HandleBad => 0, Pars => '[io,phys]A(n,m); int job(); int side();int [phys]ilo();int [phys]ihi();[phys]scale(n); int [o,phys]info()', GenericTypes => [F,D], Code => generate_code ' char pjob; char pside =\'L\' ; types(F) %{ extern int sgebak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, float *scale, integer *m, float *v, integer * ldv, integer *info); %} types(D) %{ extern int dgebak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, double *scale, integer *m, double *v, integer * ldv, integer *info); %} switch ($job()) { case 1: pjob = \'P\'; break; case 2: pjob = \'S\'; break; case 3: pjob = \'B\'; break; default: pjob = \'N\'; } if ($side()) pside = \'R\'; $TFD(sgebak_,dgebak_)( &pjob, &pside, &(integer){$PRIV(__n_size)}, $P(ilo), $P(ihi), $P(scale), &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, $P(info)); ', Doc => ' =for ref gebak forms the right or left eigenvectors of a real general matrix by backward transformation on the computed eigenvectors of the balanced matrix output by gebal. Arguments ========= A: On entry, the matrix of right or left eigenvectors to be transformed, as returned by hsein or trevc. On exit, A is overwritten by the transformed eigenvectors. job: Specifies the type of backward transformation required: = 0 , do nothing, return immediately; = 1, do backward transformation for permutation only; = 2, do backward transformation for scaling only; = 3, do backward transformations for both permutation and scaling. job must be the same as the argument job supplied to gebal. side: = 0: V contains left eigenvectors. = 1: V contains right eigenvectors; ilo: ihi: The integers ilo and ihi determined by gebal. 1 <= ilo <= ihi <= N, if N > 0; ilo=1 and ihi=0, if N=0. Here N is the the number of rows of the matrix A. scale: Details of the permutation and scaling factors, as returned by gebal. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value. =for example $a = random (50, 50); $scale = zeroes(50); $info = null; $ilo = null; $ihi = null; gebal($a, $ilo, $ihi, $scale, $info); # Compute eigenvectors ($ev) gebak($ev, $ilo, $ihi, $scale, $info); '); pp_def("lange", HandleBad => 0, Pars => '[phys]A(n,m); int norm(); [o]b()', GenericTypes => [F,D], Code => ' char pnorm; types(F) %{ extern float slange_(char *norm, integer *m, integer *n, float *a, integer *lda, float *work); float *work; %} types(D) %{ extern double dlange_(char *norm, integer *m, integer *n, double *a, integer *lda, double *work); double *work; %} switch ($norm()) { case 1: pnorm = \'O\'; break; case 2: pnorm = \'I\'; types(F) %{ work = (float *)malloc($PRIV(__n_size) * sizeof(float)); %} types(D) %{ work = (double *)malloc($PRIV(__n_size) * sizeof(double)); %} break; case 3: pnorm = \'F\'; break; default: pnorm = \'M\'; } $b() = $TFD(slange_,dlange_)( &pnorm, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, $P(A), &(integer){$PRIV(__n_size)}, work); if ($norm() == 2) free (work); ', Doc => ' =for ref Computes the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real matrix A. Description =========== returns the value lange = ( max(abs(A(i,j))), norm = 0 ( ( norm1(A), norm = 1 ( ( normI(A), norm = 2 ( ( normF(A), norm = 3 where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. Arguments ========= norm: Specifies the value to be returned in lange as described above. A: The n by m matrix A. =for example $a = random (float, 100, 100); $norm = $a->lange(1); '); pp_def("lansy", HandleBad => 0, Pars => '[phys]A(n,n); int uplo(); int norm(); [o]b()', GenericTypes => [F,D], Code => ' char pnorm, puplo = \'U\'; types(F) %{ extern float slansy_(char *norm, char *uplo, integer *n, float *a, integer *lda, float *work); float *work; %} types(D) %{ extern double dlansy_(char *norm, char *uplo, integer *n, double *a, integer *lda, double *work); double *work; %} switch ($norm()) { case 1: pnorm = \'O\'; types(F) %{ work = (float *)malloc($PRIV(__n_size) * sizeof(float)); %} types(D) %{ work = (double *)malloc($PRIV(__n_size) * sizeof(double)); %} break; case 2: pnorm = \'I\'; types(F) %{ work = (float *)malloc($PRIV(__n_size) * sizeof(float)); %} types(D) %{ work = (double *)malloc($PRIV(__n_size) * sizeof(double)); %} break; case 3: pnorm = \'F\'; break; default: pnorm = \'M\'; } if($uplo()) puplo = \'L\'; $b() = $TFD(slansy_,dlansy_)( &pnorm, &puplo, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, work); if ($norm() == 2 || $norm() == 1) free (work); ', Doc => ' =for ref Computes the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix A. Description =========== returns the value lansy = ( max(abs(A(i,j))), norm = 0 ( ( norm1(A), norm = 1 ( ( normI(A), norm = 2 ( ( normF(A), norm = 3 where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. norm: Specifies the value to be returned in lansy as described above. uplo: Specifies whether the upper or lower triangular part of the symmetric matrix A is to be referenced. = 0: Upper triangular part of A is referenced = 1: Lower triangular part of A is referenced A: The symmetric matrix A. If uplo = 0, the leading n by n upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading n by n lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. =for example # Assume $a is symmetric $a = random (float, 100, 100); $norm = $a->lansy(1, 1); '); pp_def("lantr", HandleBad => 0, Pars => '[phys]A(m,n);int uplo();int norm();int diag();[o]b()', GenericTypes => [F,D], Code => ' char pnorm, puplo = \'U\'; char pdiag = \'N\'; types(F) %{ extern float slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, float *a, integer *lda, float *work); float *work; %} types(D) %{ extern double dlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, double *a, integer *lda, double *work); double *work; %} switch ($norm()) { case 1: pnorm = \'O\'; break; case 2: pnorm = \'I\'; types(F) %{ work = (float *)malloc($PRIV(__m_size) * sizeof(float)); %} types(D) %{ work = (double *)malloc($PRIV(__m_size) * sizeof(double)); %} break; case 3: pnorm = \'F\'; break; default: pnorm = \'M\'; } if($uplo()) puplo = \'L\'; if($diag()) pdiag = \'U\'; $b() = $TFD(slantr_,dlantr_)( &pnorm, &puplo, &pdiag, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, work); if ($norm() == 2) free (work); ', Doc => ' =for ref Computes the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix A. Description =========== returns the value lantr = ( max(abs(A(i,j))), norm = 0 ( ( norm1(A), norm = 1 ( ( normI(A), norm = 2 ( ( normF(A), norm = 3 where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. norm: Specifies the value to be returned in lantr as described above. uplo: Specifies whether the matrix A is upper or lower trapezoidal. = 0: Upper triangular part of A is referenced = 1: Lower triangular part of A is referenced Note that A is triangular instead of trapezoidal if M = N. diag: Specifies whether or not the matrix A has unit diagonal. = 0: Non-unit diagonal = 1: Unit diagonal A: The trapezoidal matrix A (A is triangular if m = n). If uplo = 0, the leading m by n upper trapezoidal part of the array A contains the upper trapezoidal matrix, and the strictly lower triangular part of A is not referenced. If uplo = 1, the leading m by n lower trapezoidal part of the array A contains the lower trapezoidal matrix, and the strictly upper triangular part of A is not referenced. Note that when diag = 1, the diagonal elements of A are not referenced and are assumed to be one. =for example # Assume $a is upper triangular $a = random (float, 100, 100); $norm = $a->lantr(1, 1, 0); '); ################################################################################ # # BLAS ROUTINES # ################################################################################ pp_def("gemm", HandleBad => 0, Pars => '[phys]A(m,n); int transa(); int transb(); [phys]B(p,q);[phys]alpha(); [phys]beta(); [io,phys]C(r,s)', GenericTypes => [F,D], Code => ' char ptransa = \'N\'; char ptransb = \'N\'; types(F) %{ extern int sgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, float *alpha, float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); %} types(D) %{ extern int dgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, double *alpha, double *a, integer *lda, double *b, integer *ldb, double *beta, double *c__, integer *ldc); %} integer kk = $transa() ? $SIZE(m) : $SIZE(n); if ($transa()) ptransa = \'T\'; if ($transb()) ptransb = \'T\'; $TFD(sgemm_,dgemm_)( &ptransa, &ptransb, &(integer){$PRIV(__r_size)}, &(integer){$PRIV(__s_size)}, &kk, $P(alpha), $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}, $P(beta), $P(C), &(integer){$PRIV(__r_size)}); ', Doc => ' =for ref Performs one of the matrix-matrix operations C := alpha*op( A )*op( B ) + beta*C, where op( X ) is one of p( X ) = X or op( X ) = X\', alpha and beta are scalars, and A, B and C are matrices, with op( A ) an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. Parameters ========== transa: On entry, transa specifies the form of op( A ) to be used in the matrix multiplication as follows: transa = 0, op( A ) = A. transa = 1, op( A ) = A\'. transb: On entry, transb specifies the form of op( B ) to be used in the matrix multiplication as follows: transb = 0, op( B ) = B. transb = 1, op( B ) = B\'. alpha: On entry, alpha specifies the scalar alpha. A: Before entry with transa = 0, the leading m by k part of the array A must contain the matrix A, otherwise the leading k by m part of the array A must contain the matrix A. B: Before entry with transb = 0, the leading k by n part of the array B must contain the matrix B, otherwise the leading n by k part of the array B must contain the matrix B. beta: On entry, beta specifies the scalar beta. When beta is supplied as zero then C need not be set on input. C: Before entry, the leading m by n part of the array C must contain the matrix C, except when beta is zero, in which case C need not be set on entry. On exit, the array C is overwritten by the m by n matrix ( alpha*op( A )*op( B ) + beta*C ). =for example $a = random(5,4); $b = random(5,4); $alpha = pdl(0.5); $beta = pdl(0); $c = zeroes(5,5); gemm($a, 0, 1,$b, $alpha, $beta, $c); '); if ($config{CBLAS}){ pp_def("rmgemm", HandleBad => 0, Pars => '[phys]A(m,n); int transa(); int transb(); [phys]B(p,q);[phys]alpha(); [phys]beta(); [io,phys]C(r,s)', GenericTypes => [F,D], Code => ' int ptransa = CblasNoTrans; int ptransb = CblasNoTrans; types(F) %{ extern void cblas_sgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_TRANSPOSE TransB, const int M, const int N, const int K, const float alpha, const float *A, const int lda, const float *B, const int ldb, const float beta, float *C, const int ldc); %} types(D) %{ extern void cblas_dgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_TRANSPOSE TransB, const int M, const int N, const int K, const double alpha, const double *A, const int lda, const double *B, const int ldb, const double beta, double *C, const int ldc); %} integer kk = $transa() ? $SIZE(n) : $SIZE(m); if ($transa()) ptransa = CblasTrans; if ($transb()) ptransb = CblasTrans; $TFD(cblas_sgemm,cblas_dgemm)( CblasRowMajor, ptransa, ptransb, $PRIV(__s_size), $PRIV(__r_size), kk, $alpha(), $P(A), $PRIV(__m_size), $P(B), $PRIV(__p_size), $beta(), $P(C), $PRIV(__r_size)); ', Doc => ' =for ref Row major version of gemm =for example $a = random(5,4); $b = random(5,4); $alpha = pdl(0.5); $beta = pdl(0); $c = zeroes(4,4); rmgemm($a, 0, 1,$b, $alpha, $beta, $c); '); } pp_def("mmult", HandleBad => 0, Pars => '[phys]A(m,n); [phys]B(p,m); [o,phys]C(p,n)', GenericTypes => [F,D], Code => ' char ptrans = \'N\'; types(F) %{ extern int sgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, float *alpha, float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); float alpha = 1; float beta = 0; %} types(D) %{ extern int dgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, double *alpha, double *a, integer *lda, double *b, integer *ldb, double *beta, double *c__, integer *ldc); double alpha = 1; double beta = 0; %} $TFD(sgemm_,dgemm_)( &ptrans, &ptrans, &(integer){$PRIV(__p_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, &alpha, $P(B), &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__m_size)}, &beta, $P(C), &(integer){$PRIV(__p_size)}); ', Doc => ' =for ref Blas matrix multiplication based on gemm '); if ($config{STRASSEN}){ pp_def("smmult", HandleBad => 0, Pars => '[phys]A(m,n); [phys]B(p,m); [o,phys]C(p,n)', GenericTypes => [F,D], Code => ' char ptrans = \'N\'; types(F) %{ extern int sgemmb_(char *transa, char *transb, integer *m, integer * n, integer *k, float *alpha, float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); float alpha = 1; float beta = 0; %} types(D) %{ extern int dgemmb_(char *transa, char *transb, integer *m, integer * n, integer *k, double *alpha, double *a, integer *lda, double *b, integer *ldb, double *beta, double *c__, integer *ldc); double alpha = 1; double beta = 0; %} $TFD(sgemmb_,dgemmb_)( &ptrans, &ptrans, &(integer){$PRIV(__p_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, &alpha, $P(B), &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__m_size)}, &beta, $P(C), &(integer){$PRIV(__p_size)}); ', Doc => ' =for ref Blas matrix multiplication based on Strassen Algorithm. '); } pp_def("crossprod", HandleBad => 0, Pars => '[phys]A(n,m); [phys]B(p,m); [o,phys]C(p,n)', GenericTypes => [F,D], Code => ' char btrans = \'N\'; char atrans = \'T\'; types(F) %{ extern int sgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, float *alpha, float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); float alpha = 1; float beta = 0; %} types(D) %{ extern int dgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, double *alpha, double *a, integer *lda, double *b, integer *ldb, double *beta, double *c__, integer *ldc); double alpha = 1; double beta = 0; %} $TFD(sgemm_,dgemm_)( &btrans, &atrans, &(integer){$PRIV(__p_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__m_size)}, &alpha, $P(B), &(integer){$PRIV(__p_size)}, $P(A), &(integer){$PRIV(__n_size)}, &beta, $P(C), &(integer){$PRIV(__p_size)}); ', Doc => ' =for ref Blas matrix cross product based on gemm '); pp_def("syrk", HandleBad => 0, Pars => '[phys]A(m,n); int uplo(); int trans(); [phys]alpha(); [phys]beta(); [io,phys]C(p,p)', GenericTypes => [F,D], Code => ' char puplo = \'U\'; char ptrans = \'N\'; types(F) %{ extern int ssyrk_(char *uplo, char *trans, integer *n, integer *k, float *alpha, float *a, integer *lda, float *beta, float *c__, integer *ldc); %} types(D) %{ extern int dsyrk_(char *uplo, char *trans, integer *n, integer *k, double *alpha, double *a, integer *lda, double *beta, double *c__, integer *ldc); %} integer kk = $trans() ? $SIZE(m) : $SIZE(n); if ($uplo()) puplo = \'L\'; if ($trans()) ptrans = \'T\'; $TFD(ssyrk_,dsyrk_)( &puplo, &ptrans, &(integer){$PRIV(__p_size)}, &kk, $P(alpha), $P(A), &(integer){$PRIV(__m_size)}, $P(beta), $P(C), &(integer){$PRIV(__p_size)}); ', Doc => ' =for ref Performs one of the symmetric rank k operations C := alpha*A*A\' + beta*C, or C := alpha*A\'*A + beta*C, where alpha and beta are scalars, C is an n by n symmetric matrix and A is an n by k matrix in the first case and a k by n matrix in the second case. Parameters ========== uplo: On entry, uplo specifies whether the upper or lower triangular part of the array C is to be referenced as follows: uplo = 0 Only the upper triangular part of C is to be referenced. uplo = 1 Only the lower triangular part of C is to be referenced. Unchanged on exit. trans: On entry, trans specifies the operation to be performed as follows: trans = 0 C := alpha*A*A\' + beta*C. trans = 1 C := alpha*A\'*A + beta*C. alpha: On entry, alpha specifies the scalar alpha. Unchanged on exit. A: Before entry with trans = 0, the leading n by k part of the array A must contain the matrix A, otherwise the leading k by n part of the array A must contain the matrix A. beta: On entry, beta specifies the scalar beta. C: Before entry with uplo = 0, the leading n by n upper triangular part of the array C must contain the upper triangular part of the symmetric matrix and the strictly lower triangular part of C is not referenced. On exit, the upper triangular part of the array C is overwritten by the upper triangular part of the updated matrix. Before entry with uplo = 1, the leading n by n lower triangular part of the array C must contain the lower triangular part of the symmetric matrix and the strictly upper triangular part of C is not referenced. On exit, the lower triangular part of the array C is overwritten by the lower triangular part of the updated matrix. =for example $a = random(5,4); $b = zeroes(5,5); $alpha = 1; $beta = 0; syrk ($a, 1,0,$alpha, $beta , $b); '); if ($config{CBLAS}){ pp_def("rmsyrk", HandleBad => 0, Pars => '[phys]A(m,n); int uplo(); int trans(); [phys]alpha(); [phys]beta(); [io,phys]C(p,p)', GenericTypes => [F,D], Code => ' int puplo = 121; int ptrans = 111; types(F) %{ extern void cblas_ssyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE Trans, const int N, const int K, const float alpha, const float *A, const int lda, const float beta, float *C, const int ldc); %} types(D) %{ extern void cblas_dsyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE Trans, const int N, const int K, const double alpha, const double *A, const int lda, const double beta, double *C, const int ldc); %} integer kk = $trans() ? $SIZE(n) : $SIZE(m); if ($uplo()) puplo = 122; if ($trans()) ptrans = 112; $TFD(cblas_ssyrk,cblas_dsyrk)( 101, puplo, ptrans, $PRIV(__p_size), kk, $alpha(), $P(A), $PRIV(__m_size), $beta(), $P(C), $PRIV(__p_size)); ', Doc => ' =for ref Row major version of syrk =for example $a = random(5,4); $b = zeroes(4,4); $alpha = 1; $beta = 0; rmsyrk ($a, 1,0,$alpha, $beta , $b); '); } pp_def("dot", HandleBad => 0, Pars => '[phys]a(n);int [phys]inca();[phys]b(m);int [phys]incb();[o,phys]c()', GenericTypes => [F,D], Code => ' types(F) %{ extern float sdot_(integer *n, float *dx, integer *incx, float *dy, integer *incy); %} types(D) %{ extern double ddot_(integer *n, double *dx, integer *incx, double *dy, integer *incy); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $c() = $TFD(sdot_,ddot_)( &n, $P(a), $P(inca), $P(b), $P(incb)); ', Doc => ' =for ref Dot product of two vectors using Blas. =for example $a = random(5); $b = random(5); $c = dot($a, 1, $b, 1) '); pp_def("axpy", HandleBad => 0, Pars => '[phys]a(n);int [phys]inca();[phys] alpha();[io,phys]b(m);int [phys]incb()', GenericTypes => [F,D], Code => ' types(F) %{ extern int saxpy_(integer *n, float *da, float *dx, integer *incx, float *dy, integer *incy); %} types(D) %{ extern int daxpy_(integer *n, double *da, double *dx, integer *incx, double *dy, integer *incy); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $TFD(saxpy_,daxpy_)( &n, $P(alpha), $P(a), $P(inca), $P(b), $P(incb)); ', Doc => ' =for ref Linear combination of vectors ax + b using Blas. Returns result in b. =for example $a = random(5); $b = random(5); axpy($a, 1, 12, $b, 1) '); pp_def("nrm2", HandleBad => 0, Pars => '[phys]a(n);int [phys]inca();[o,phys]b()', GenericTypes => [F,D], Code => ' types(F) %{ extern float snrm2_(integer *n, float *dx, integer *incx); %} types(D) %{ extern double dnrm2_(integer *n, double *dx, integer *incx); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $b() = $TFD(snrm2_,dnrm2_)( &n, $P(a), $P(inca)); ', Doc => ' =for ref Euclidean norm of a vector using Blas. =for example $a = random(5); $norm2 = norm2($a,1) '); pp_def("asum", HandleBad => 0, Pars => '[phys]a(n);int [phys]inca();[o,phys]b()', GenericTypes => [F,D], Code => ' types(F) %{ extern float sasum_(integer *n, float *dx, integer *incx); %} types(D) %{ extern double dasum_(integer *n, double *dx, integer *incx); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $b() = $TFD(sasum_,dasum_)( &n, $P(a), $P(inca)); ', Doc => ' =for ref Sum of absolute values of a vector using Blas. =for example $a = random(5); $absum = asum($a,1) '); pp_def("scal", HandleBad => 0, Pars => '[io,phys]a(n);int [phys]inca();[phys]scale()', GenericTypes => [F,D], Code => ' types(F) %{ extern int sscal_(integer *n, float *sa, float *dx, integer *incx); %} types(D) %{ extern int dscal_(integer *n, double *sa, double *dx,integer *incx); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $TFD(sscal_,dscal_)( &n, $P(scale), $P(a), $P(inca)); ', Doc => ' =for ref Scale a vector by a constant using Blas. =for example $a = random(5); $a->scal(1, 0.5) '); pp_def("rot", HandleBad => 0, Pars => '[io,phys]a(n);int [phys]inca();[phys]c(); [phys]s();[io,phys]b(n);int [phys]incb()', GenericTypes => [F,D], Code => ' types(F) %{ extern int srot_(integer *n, float *dx, integer *incx, float *dy, integer *incy, float *c, float *s); %} types(D) %{ extern int drot_(integer *n, double *dx, integer *incx, double *dy, integer *incy, double *c, double *s); %} integer n = (integer ) $PRIV(__n_size)/$inca(); $TFD(srot_,drot_)( &n, $P(a), $P(inca), $P(b), $P(incb), $P(c), $P(s) ); ', Doc => ' =for ref Applies plane rotation using Blas. =for example $a = random(5); $b = random(5); rot($a, 1, 0.5, 0.7, $b, 1) '); pp_def("rotg", HandleBad => 0, Pars => '[io,phys]a();[io,phys]b();[o,phys]c(); [o,phys]s()', GenericTypes => [F,D], Code => ' types(F) %{ extern int srotg_(float *dx, float *dy, float *c, float *s); %} types(D) %{ extern int drotg_(double *dx, double *dy, double *c, double *s); %} $TFD(srotg_,drotg_)( $P(a), $P(b), $P(c), $P(s) ); ', Doc => ' =for ref Generates plane rotation using Blas. =for example $a = sequence(4); rotg($a(0), $a(1),$a(2),$a(3)) '); ################################################################################ # # LAPACK AUXILIARY ROUTINES # ################################################################################ pp_def("lasrt", HandleBad => 0, Pars => '[io,phys]d(n); int id();int [o,phys]info()', GenericTypes => [F,D], Code => ' char pwork = \'I\'; types(F) %{ extern int slasrt_(char *id, integer *n, float *d__, integer * info); %} types(D) %{ extern int dlasrt_(char *id, integer *n, double *d__, integer * info); %} if ($id()) pwork = \'D\'; $TFD(slasrt_,dlasrt_)( &pwork, &(integer){$PRIV(__n_size)}, $P(d), $P(info)); ', Doc => ' =for ref Sort the numbers in d in increasing order (if id = 0) or in decreasing order (if id = 1 ). Use Quick Sort, reverting to Insertion sort on arrays of size <= 20. Dimension of stack limits N to about 2**32. Arguments ========= id: = 0: sort d in increasing order; = 1: sort d in decreasing order. d: On entry, the array to be sorted. On exit, d has been sorted into increasing order (d(1) <= ... <= d(N) ) or into decreasing order (d(1) >= ... >= d(N) ), depending on id. info: = 0: successful exit < 0: if info = -i, the i-th argument had an illegal value =for example $a = random(5); lasrt ($a, 0, ($info = null)); '); pp_def("lacpy", HandleBad => 0, Pars => '[phys]A(m,n); int uplo(); [o,phys]B(p,n)', GenericTypes => [F,D], Code => ' char puplo; types(F) %{ extern int slacpy_(char *uplo, integer *m, integer *n, float * a, integer *lda, float *b, integer *ldb); %} types(D) %{ extern int dlacpy_(char *uplo, integer *m, integer *n, double * a, integer *lda, double *b, integer *ldb); %} switch ($uplo()) { case 0: puplo = \'U\'; break; case 1: puplo = \'L\'; break; default: puplo = \'A\'; } $TFD(slacpy_,dlacpy_)( &puplo, &(integer){$PRIV(__m_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(B), &(integer){$PRIV(__p_size)}); ', Doc => ' =for ref Copies all or part of a two-dimensional matrix A to another matrix B. Arguments ========= uplo: Specifies the part of the matrix A to be copied to B. = 0: Upper triangular part = 1: Lower triangular part Otherwise: All of the matrix A A: The m by n matrix A. If uplo = 0, only the upper triangle or trapezoid is accessed; if uplo = 1, only the lower triangle or trapezoid is accessed. B: On exit, B = A in the locations specified by uplo. =for example $a = random(5,5); $b = zeroes($a); lacpy ($a, 0, $b); '); pp_def("laswp", HandleBad => 0, Pars => '[io,phys]A(m,n);int [phys]k1();int [phys] k2(); int [phys]ipiv(p);int [phys]inc()', GenericTypes => [F,D], Code => ' types(F) %{ extern int slaswp_(integer *n, float *a, integer *lda, integer *k1, integer *k2, integer *ipiv, integer *incx); %} types(D) %{ extern int dlaswp_(integer *n, double *a, integer *lda, integer *k1, integer *k2, integer *ipiv, integer *incx); %} $TFD(slaswp_,dlaswp_)( &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__m_size)}, $P(k1), $P(k2), $P(ipiv), $P(inc)); ', Doc => ' =for ref Performs a series of row interchanges on the matrix A. One row interchange is initiated for each of rows k1 through k2 of A. Dosen\'t use PDL indice (start = 1). Arguments ========= A: On entry, the matrix of column dimension N to which the row interchanges will be applied. On exit, the permuted matrix. k1: The first element of ipiv for which a row interchange will be done. k2: The last element of ipiv for which a row interchange will be done. ipiv: The vector of pivot indices. Only the elements in positions k1 through k2 of ipiv are accessed. ipiv(k) = l implies rows k and l are to be interchanged. inc: The increment between successive values of ipiv. If ipiv is negative, the pivots are applied in reverse order. =for example $a = random(5,5); # reverse row (col for PDL) $b = pdl([5,4,3,2,1]); $a->laswp(1,2,$b,1); '); pp_def("lamch", HandleBad => 0, Pars => 'cmach(); [o]precision()', GenericTypes => [F,D], Inplace => 1, Code => ' char pcmach; int tmp; types(F) %{ extern float slamch_(char *cmach); %} types(D) %{ extern double dlamch_(char *cmach); %} tmp = (int ) $cmach(); switch (tmp) { case 1: pcmach = \'S\'; break; case 2: pcmach = \'B\'; break; case 3: pcmach = \'P\'; break; case 4: pcmach = \'N\'; break; case 5: pcmach = \'R\'; break; case 6: pcmach = \'M\'; break; case 7: pcmach = \'U\'; break; case 8: pcmach = \'L\'; break; case 9: pcmach = \'O\'; break; default: pcmach = \'E\'; } $precision() = $TFD(slamch_,dlamch_)(&pcmach); ', Doc => ' =for ref Determines precision machine parameters. Works inplace. Arguments ========= cmach: Specifies the value to be returned by lamch: = 0 LAMCH := eps = 1 LAMCH := sfmin = 2 LAMCH := base = 3 LAMCH := eps*base = 4 LAMCH := t = 5 LAMCH := rnd = 6 LAMCH := emin = 7 LAMCH := rmin = 8 LAMCH := emax = 9 LAMCH := 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) =for example $a = lamch (0); print "EPS is $a for double\n"; '); pp_def("labad", HandleBad => 0, Pars => '[io,phys]small(); [io,phys]large()', GenericTypes => [F,D], Code => ' types(F) %{ extern int slabad_(float *small, float *large); %} types(D) %{ extern int dlabad_(double *small, double *large); %} $TFD(slabad_, dlabad_)($P(small),$P(large)); ', Doc => ' =for ref Takes as input the values computed by C for underflow and overflow, and returns the square root of each of these values if the log of large is sufficiently large. This subroutine is intended to identify machines with a large exponent range, such as the Crays, and redefine the underflow and overflow limits to be the square roots of the values computed by C. This subroutine is needed because lamch does not compensate for poor arithmetic in the upper half of the exponent range, as is found on a Cray. Arguments ========= small: On entry, the underflow threshold as computed by lamch. On exit, if LOG10(large) is sufficiently large, the square root of small, otherwise unchanged. large: On entry, the overflow threshold as computed by lamch. On exit, if LOG10(large) is sufficiently large, the square root of large, otherwise unchanged. =for example $underflow = lamch(7); $overflow = lamch(9); labad ($underflow, $overflow); '); ################################################################################ # # OTHER AUXILIARY ROUTINES # ################################################################################ pp_def( 'tricpy', Pars => 'A(m,n);int uplo();[o] C(m,n)', Code => ' PDL_Long i, j, k; if ($uplo()) { for (i = 0; i < $SIZE(n);i++) { k = min(i,($SIZE(m)-1)); for (j = 0; j <= k; j++) $C(m=>j,n=>i) = $A(m=>j,n=>i); } } else { for (i = 0; i < $SIZE(n);i++) { for (j = i; j < $SIZE(m); j++) $C(m=>j,n=>i) = $A(m=>j,n=>i); if (i >= $SIZE(m)) break; } } ', Doc => < 'eigreval(n);eigimval(n); eigvec(n,p);int fortran();[o]cplx_val(q=2,n);[o]cplx_vec(r=2,n,p)', Code => ' register PDL_Long i,j; PDL_Long index; if ($fortran()) { if ($SIZE(n) != $SIZE(p)) croak("Fortran storage type needs square eigvec!"); for(i = 0; i < $SIZE(p);i++) { if ($eigimval(n=>i) == 0) { $cplx_val(q=>0,n=>i) = $eigreval(n=>i); $cplx_val(q=>1,n=>i) = $eigimval(n=>i); for (j = 0; j < $SIZE(n); j++) { $cplx_vec(r=>0,n=>j,p=>i) = $eigvec(n=>j,p=>i); $cplx_vec(r=>1,n=>j,p=>i) = 0; } } else { index = i+1; $cplx_val(q=>0,n=>i) = $eigreval(n=>i); $cplx_val(q=>1,n=>i) = $eigimval(n=>i); $cplx_val(q=>0,n=>index) = $eigreval(n=>index); $cplx_val(q=>1,n=>index) = $eigimval(n=>index); for (j = 0; j < $SIZE(n); j++) { $cplx_vec(r=>0,n=>j,p=>i) = $cplx_vec(r=>0,n=>j,p=>index) = $eigvec(n=>j,p=>i); $cplx_vec(r=>1,n=>j,p=>i) = $eigvec(n=>j,p=>index); $cplx_vec(r=>1,n=>j,p=>index) = - $eigvec(n=>j,p=>index); } i = index; } } } else{ for(i = 0; i < $SIZE(n);i++) { if ($eigimval(n=>i) == 0) { $cplx_val(q=>0,n=>i) = $eigreval(n=>i); $cplx_val(q=>1,n=>i) = $eigimval(n=>i); for (j = 0; j < $SIZE(p); j++) { $cplx_vec(r=>0,n=>i,p=>j) = $eigvec(n=>i,p=>j); $cplx_vec(r=>1,n=>i,p=>j) = 0; } } else { index = i+1; $cplx_val(q=>0,n=>i) = $eigreval(n=>i); $cplx_val(q=>1,n=>i) = $eigimval(n=>i); $cplx_val(q=>0,n=>index) = $eigreval(n=>index); $cplx_val(q=>1,n=>index) = $eigimval(n=>index); for (j = 0; j < $SIZE(p); j++) { $cplx_vec(r=>0,n=>i,p=>j) = $cplx_vec(r=>0,n=>index,p=>j) = $eigvec(n=>i,p=>j); $cplx_vec(r=>1,n=>i,p=>j) = $eigvec(n=>index,p=>j); $cplx_vec(r=>1,n=>index,p=>j) = - $eigvec(n=>index,p=>j); } i = index; } } } ', Doc => < 1, Reversible => 1, Pars => 'x(n); y(p);[o]out(q)', RedoDimsCode => '$SIZE(q) = ( $PDL(x)->ndims > 0 ? $PDL(x)->dims[0] : 1) + ( $PDL(y)->ndims > 0 ? $PDL(y)->dims[0] : 1);', Code => ' register PDL_Long i,j; for (i=0; i < $SIZE(n); i++){ $out(q=>i) = $x(n=>i); } j = 0; for (i=$SIZE(n); i < $SIZE(q); i++){ $out(q=>i) = $y(p=>j); j++; } ', BackCode => ' register PDL_Long i,j; for (i=0; i < $SIZE(n); i++){ $x(n=>i) = $out(q=>i); } j = 0; for (i=$SIZE(n); i < $SIZE(q); i++){ $y(p=>j) = $out(q=>i); j++; } ', Doc => < 1, Reversible => 1, Pars => 'x(n,m);y(n,p);[o]out(n,q);', RedoDimsCode => '$SIZE(q) = $PDL(x)->dims[1] + $PDL(y)->dims[1];', Code => ' register PDL_Long i,j; loop(m)%{ loop(n)%{ $out(n=>n,q=>m) = $x(); %} %} j=0; for (i = $SIZE(m); i < $SIZE(q) ;i++,j++) { loop(n)%{ $out(n=>n,q=>i) = $y(n=>n,p=>j); %} } ', BackCode => ' register PDL_Long i,j; loop(m)%{ loop(n)%{ $x() = $out(n=>n,q=>m); %} %} j=0; for (i = $SIZE(m); i < $SIZE(q) ;i++,j++) { loop(n)%{ $y(n=>n,p=>j) = $out(n=>n,q=>i); %} } ', Doc => < '$SIZE(q) = $PDL(x)->dims[1] + $PDL(y)->dims[1];', pp_addhdr(' float ftrace(int n, float *mat) { int i; float sum = mat[0]; for (i = 1; i < n; i++) sum += mat[i*(n+1)]; return sum; } double dtrace(int n, double *mat) { int i; double sum = mat[0]; for (i = 1; i < n; i++) sum += mat[i*(n+1)]; return sum; } '); pp_def( 'charpol', RedoDimsCode => '$SIZE(p) = $PDL(A)->dims[0] + 1;', Pars => '[phys]A(n,n);[phys,o]Y(n,n);[phys,o]out(p);', GenericTypes => [F,D], Code => ' int i,j,k; $GENERIC() *p, b; //$GENERIC() *tmp; char ptrans = \'N\'; types(F) %{ extern int sgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, float *alpha, float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); float alpha = 1; float beta = 0; %} types(D) %{ extern int dgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, double *alpha, double *a, integer *lda, double *b, integer *ldb, double *beta, double *c__, integer *ldc); double alpha = 1; double beta = 0; %} p = ($GENERIC() * ) malloc ( $SIZE(n) * $SIZE(n) * sizeof($GENERIC())); loop(n0)%{ loop(n1)%{ $Y(n0=>n0,n1=>n1) = (n0 == n1) ? ($GENERIC()) 1.0 : ($GENERIC()) 0.0; %} %} $out(p=>0) = 1; i = 0; for (;;) { i++; $TFD(sgemm_,dgemm_)(&ptrans,&ptrans,&(integer){$PRIV(__n_size)},&(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)},&alpha,$P(A),&(integer){$PRIV(__n_size)}, $P(Y), &(integer){$PRIV(__n_size)}, &beta, p, &(integer){$PRIV(__n_size)}); if (i == $SIZE(n)) break; //tmp = $P(Y); //$P(Y) = p; //p = tmp; memmove($P(Y), p, $SIZE(n) * $SIZE(n) * sizeof($GENERIC())); // loop(n1) // %{ // loop(n0) // %{ // $Y(n0=>n0,n1=>n1) = p[(n1*$SIZE(n))+n0]; // %} // %} b = $out(p=>i) = - $TFD(ftrace,dtrace)($SIZE(n), $P(Y)) / i; for (j = 0; j < $SIZE(n); j++) $Y(n0=>j,n1=>j) += b; } k = $SIZE(n); $out(p=>k) = - $TFD(ftrace,dtrace)(k, p) / k; if ((k+1) & 1) { loop(n0) %{ loop(n1) %{ $Y(n0=>n0,n1=>n1) = -$Y(n0=>n0,n1=>n1); %} %} } free(p); ', Doc => <'Bot'},<<'EOD'); =head1 AUTHOR Copyright (C) Grégory Vanuxem 2005-2007. This library is free software; you can redistribute it and/or modify it under the terms of the artistic license as specified in the Artistic file. =cut EOD pp_done(); # you will need this to finish pp processing PDL-LinearAlgebra-0.12/Special/0000755113142400244210000000000012535325330020340 5ustar chris.h.marshallDomain UsersPDL-LinearAlgebra-0.12/Special/Makefile.PL0000755113142400244210000000027312535324546022327 0ustar chris.h.marshallDomain Usersuse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::LinearAlgebra::Special', 'VERSION_FROM' => 'Special.pm', 'clean' => { FILES => '*~' }, ); __END__ PDL-LinearAlgebra-0.12/Special/Special.pm0000644113142400244210000002042712535324053022264 0ustar chris.h.marshallDomain Userspackage PDL::LinearAlgebra::Special; use PDL::Core; use PDL::NiceSlice; use PDL::Slices; use PDL::Basic qw (sequence xvals yvals); use PDL::MatrixOps qw (identity); use PDL::LinearAlgebra qw ( ); use PDL::LinearAlgebra::Real; use PDL::LinearAlgebra::Complex; use PDL::Exporter; no warnings 'uninitialized'; @EXPORT_OK = qw( mhilb mvander mpart mhankel mtoeplitz mtri mpascal mcompanion); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); our $VERSION = '0.12'; $VERSION = eval $VERSION; our @ISA = ( 'PDL::Exporter'); use strict; =encoding Latin-1 =head1 NAME PDL::LinearAlgebra::Special - Special matrices for PDL =head1 SYNOPSIS use PDL::LinearAlgebra::Mtype; $a = mhilb(5,5); =head1 DESCRIPTION This module provides some constructors of well known matrices. =head1 FUNCTIONS =head2 mhilb =for ref Contruct Hilbert matrix from specifications list or template piddle =for usage PDL(Hilbert) = mpart(PDL(template) | ARRAY(specification)) =for example my $hilb = mhilb(float,5,5); =cut sub mhilb { if(ref($_[0]) && ref($_[0]) eq 'PDL'){ my $pdl = shift; $pdl->mhilb(@_); } else{ PDL->mhilb(@_); } } sub PDL::mhilb { my $class = shift; my $pdl1 = scalar(@_)? $class->new_from_specification(@_) : $class->copy; my $pdl2 = scalar(@_)? $class->new_from_specification(@_) : $class->copy; 1 / ($pdl1->inplace->axisvals + $pdl2->inplace->axisvals(1) + 1); } =head2 mtri =for ref Return zeroed matrix with upper or lower triangular part from another matrix. Return trapezoid matrix if entry matrix is not square. Supports threading. Uses L or L. =for usage PDL = mtri(PDL, SCALAR) SCALAR : UPPER = 0 | LOWER = 1, default = 0 =for example my $a = random(10,10); my $b = mtri($a, 0); =cut sub mtri{ my $m = shift; $m->mtri(@_); } sub PDL::mtri { my ($m, $upper) = @_; my(@dims) = $m->dims; barf("mtri requires a 2-D matrix") unless( @dims >= 2); my $b = PDL::zeroes $m; $m->tricpy($upper, $b); $b; } sub PDL::Complex::mtri { my ($m, $upper) = @_; my(@dims) = $m->dims; barf("mtri requires a 2-D matrix") unless( @dims >= 3); my $b = PDL::zeroes $m; $m->ctricpy($upper, $b); $b; } =head2 mvander Return (primal) Vandermonde matrix from vector. =for ref mvander(M,P) is a rectangular version of mvander(P) with M Columns. =cut sub mvander($;$) { my $exp = @_ == 2 ? sequence(shift) : sequence($_[0]->dim(-1)); $_[0]->dummy(-2)**$exp; } =head2 mpart =for ref Return antisymmetric and symmetric part of a real or complex square matrix. =for usage ( PDL(antisymmetric), PDL(symmetric) ) = mpart(PDL, SCALAR(conj)) conj : if true Return AntiHermitian, Hermitian part. =for example my $a = random(10,10); my ( $antisymmetric, $symmetric ) = mpart($a); =cut *mpart = \&PDL::mpart; sub PDL::mpart { my ($m, $conj) = @_; my @dims = $m->dims; barf("mpart requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); # antisymmetric and symmetric part return (0.5* ($m - $m->t($conj))),(0.5* ($m + $m->t($conj))); } =head2 mhankel =for ref Return Hankel matrix also known as persymmetric matrix. For complex, needs object of type PDL::Complex. =for usage mhankel(c,r), where c and r are vectors, returns matrix whose first column is c and whose last row is r. The last element of c prevails. mhankel(c) returns matrix whith element below skew diagonal (anti-diagonal) equals to zero. If c is a scalar number, make it from sequence beginning at one. =for ref The elements are: H (i,j) = c (i+j), i+j+1 <= m; H (i,j) = r (i+j-m+1), otherwise where m is the size of the vector. If c is a scalar number, it's determinant can be computed by: floor(n/2) n Det(H(n)) = (-1) * n =cut *mhankel = \&PDL::mhankel; sub PDL::mhankel { my ($m, $n) = @_; $m = xvals($m) + 1 unless ref($m); my @dims = $m->dims; $n = PDL::zeroes($m) unless defined $n; my $index = xvals($dims[-1]); $index = $index->dummy(0) + $index; if (@dims == 2){ $m = mstack($m,$n(,1:)); $n = $m->re->index($index)->r2C; $n((1),).= $m((1),)->index($index); return $n; } else{ $m = augment($m,$n(1:)); return $m->index($index)->sever; } } =head2 mtoeplitz =for ref Return toeplitz matrix. For complex need object of type PDL::Complex. =for usage mtoeplitz(c,r), where c and r are vectors, returns matrix whose first column is c and whose last row is r. The last element of c prevails. mtoeplitz(c) returns symmetric matrix. =cut *mtoeplitz = \&PDL::mtoeplitz; sub PDL::mtoeplitz { my ($m, $n) = @_; my($res, $min); $n = $m->copy unless defined $n; my $mdim= $m->dim(-1); my $ndim= $n->dim(-1); $res = PDL::new_from_specification('PDL',$m->type,$ndim,$mdim); $ndim--; $min = $mdim <= $ndim ? $mdim : $ndim; if(UNIVERSAL::isa($m,'PDL::Complex')){ $res= $res->r2C; for(1..$min){ $res(,$_:,($_-1)) .= $n(,1:$ndim-$_+1); } $mdim--; $min = $mdim < $ndim ? $mdim : $ndim; for(0..$min){ $res(,($_),$_:) .= $m(,:$mdim-$_); } } else{ for(1..$min){ $res($_:,($_-1)) .= $n(1:$ndim-$_+1); } $mdim--; $min = $mdim < $ndim ? $mdim : $ndim; for(0..$min){ $res(($_),$_:) .= $m(:$mdim-$_); } } return $res; } =head2 mpascal Return Pascal matrix (from Pascal's triangle) of order N. =for usage mpascal(N,uplo). uplo: 0 => upper triangular (Cholesky factor), 1 => lower triangular (Cholesky factor), 2 => symmetric. =for ref This matrix is obtained by writing Pascal's triangle (whose elements are binomial coefficients from index and/or index sum) as a matrix and truncating appropriately. The symmetric Pascal is positive definite, it's inverse has integer entries. Their determinants are all equal to one and: S = L * U where S, L, U are symmetric, lower and upper pascal matrix respectively. =cut *mpascal = \&PDL::mpascal; sub PDL::mpascal { my ($m, $n) = @_; my ($mat, $error, $warning); $mat = eval{ require PDL::Stat::Distributions; $mat = xvals($m); if ($n > 1){ return (PDL::Stat::Distributions::choose($mat + $mat->dummy(0),$mat))[0]; } else{ $mat = PDL::Stat::Distributions::choose($mat,$mat->dummy(0)); return $n ? $mat->xchg(0,1)->mtri(1) : $mat->mtri; } }; if ($@){ $mat = eval{ require PDL::GSLSF::GAMMA; if ($n > 1){ $mat = xvals($m); return (PDL::GSLSF::GAMMA::gsl_sf_choose($mat + $mat->dummy(0),$mat))[0]; }else{ $mat = xvals($m, $m); return (PDL::GSLSF::GAMMA::gsl_sf_choose($mat->tritosym,$mat->xchg(0,1)->tritosym))[0]->mtri($n); } }; if ($@){ warn("mpascal: can't compute binomial coefficients with neither". " PDL::Stat::Distributions nor PDL::GSLSF::GAMMA\n"); return; } } $mat; } =head2 mcompanion Return a matrix with characteristic polynomial equal to p if p is monic. If p is not monic the characteristic polynomial of A is equal to p/c where c is the coefficient of largest degree in p (here p is in descending order). =for usage mcompanion(PDL(p),SCALAR(charpol)). charpol: 0 => first row is -P(1:n-1)/P(0), 1 => last column is -P(1:n-1)/P(0), =cut *mcompanion = \&PDL::mcompanion; sub PDL::mcompanion{ my ($m, $char) = @_; my( @dims, $dim, $ret); $m = $m->{PDL} if (UNIVERSAL::isa($m, 'HASH') && exists $m->{PDL}); @dims = $m->dims; $dim = $dims[-1] - 1; if (@dims == 2){ if($char){ $ret = (-$m->slice(",1:$dim")->dummy(2)/$m->slice(",0"))->cmstack(identity($dim-1)->r2C->mstack(zeroes(2,$dim-1)->dummy(1))); } else{ #zeroes($dim-1)->dummy(0)->augment(identity($dim-1))->mstack(-$m->slice("$dim:1")->dummy(-1)/$m->slice("(0)")); $ret = zeroes($dim-1)->r2C->dummy(2)->cmstack(identity($dim-1)->r2C)->mstack(-$m->slice(",$dim:1")->dummy(1)/$m->slice(",(0)")); } } else{ if($char){ $ret = (-$m->slice("1:$dim")->dummy(-1)/$m->slice("0"))->mstack(identity($dim-1)->augment(zeroes($dim-1)->dummy(0))); } else{ #zeroes($dim-1)->dummy(0)->augment(identity($dim-1))->mstack(-$m->slice("$dim:1")->dummy(-1)/$m->slice("(0)")); $ret = zeroes($dim-1)->dummy(-1)->mstack(identity($dim-1))->augment(-$m->slice("$dim:1")->dummy(0)/$m->slice("(0)")); } } $ret->sever; } =head1 AUTHOR Copyright (C) Grégory Vanuxem 2005-2007. This library is free software; you can redistribute it and/or modify it under the terms of the artistic license as specified in the Artistic file. =cut # Exit with OK status 1; PDL-LinearAlgebra-0.12/t/0000755113142400244210000000000012535325330017223 5ustar chris.h.marshallDomain UsersPDL-LinearAlgebra-0.12/t/1.t0000644113142400244210000000135712247720255017563 0ustar chris.h.marshallDomain Users#!/usr/bin/perl use PDL::LiteF; use PDL::LinearAlgebra; use PDL::LinearAlgebra::Trans qw //; use PDL::Complex; use Test; BEGIN { plan tests => 9 }; sub fapprox { my($a,$b) = @_; PDL::abs($a-$b)->max < 0.0001; } $a = pdl([[1.7,3.2],[9.2,7.3]]); ok(fapprox($a->t,$a->xchg(0,1))); $aa = cplx random(2,2,2); ok(fapprox($aa->t(0),$aa->xchg(1,2))); $id = pdl([[1,0],[0,1]]); ok(fapprox($a->minv x $a,$id)); ok(fapprox($a->mcrossprod->mposinv->tritosym x $a->mcrossprod,$id)); ok(fapprox($a->mdet ,-17.03 )); ok($a->mcrossprod->mposdet !=0); ok(fapprox($a->mcos->macos,pdl([[1.7018092, 0.093001244],[0.26737858,1.8645614]]))); ok(fapprox($a->msin->masin,pdl([[ -1.4397834,0.093001244],[0.26737858,-1.2770313]]))); ok(fapprox($a->mexp->mlog,$a)); PDL-LinearAlgebra-0.12/Trans/0000755113142400244210000000000012535325330020047 5ustar chris.h.marshallDomain UsersPDL-LinearAlgebra-0.12/Trans/Makefile.PL0000644113142400244210000000236512535324555022037 0ustar chris.h.marshallDomain Users # Use this as a template for the Makefile.PL for # any external PDL module. use ExtUtils::MakeMaker; use PDL::Core::Dev; use Config; @pack = (["trans.pd",Trans,PDL::LinearAlgebra::Trans]); %hash = pdlpp_stdargs(@::pack); # $hash{'OPTIMIZE'} = '-O2 -mtune=k8'; # If you want to debug, uncomment this. $hash{LIBS}[0] .= ( eval {require PkgConfig; join ' ', PkgConfig->find('lapack')->get_ldflags} || eval {require ExtUtils::PkgConfig; ExtUtils::PkgConfig->libs('lapack')} || `pkg-config lapack blas --libs` || '-L/usr/lib/atlas -llapack -lblas -latlas' ) . " -lgfortran -lquadmath"; $hash{LDLOADLIBS} .= 'oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib msvcrt.lib ../lapack/libacml.lib "C:\Program Files\Microsoft Visual Studio .NET 2003\Vc7\lib\msvcrt.lib" ' if $^O =~ /MSWin/ && $Config{cc} eq 'cl'; WriteMakefile( %hash, 'VERSION_FROM' => 'trans.pd', 'clean' => { FILES => '*~' }, ); # Add genpp rule # add other makefile additions as required (see also ExtUtils::MakeMaker) sub MY::postamble { pdlpp_postamble(@::pack); } PDL-LinearAlgebra-0.12/Trans/Makefile.PL.pkg0000644113142400244210000000156412247720255022614 0ustar chris.h.marshallDomain Users # Use this as a template for the Makefile.PL for # any external PDL module. use ExtUtils::MakeMaker; PDL::Core::Dev->import(); @pack = (["Trans.pd",Trans,PDL::LinearAlgebra::Trans]); %hash = pdlpp_stdargs_int(@::pack); # $hash{'OPTIMIZE'} = '-g'; # If you want to debug, uncomment this. $hash{LIBS}[0] .= $^O =~ /MSWin/ ? '' : '-L/usr/lib/atlas -llapack -lf77blas -lcblas -latlas -lg2c '; $hash{LDLOADLIBS} .= 'oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib msvcrt.lib ../lapack/lapack.lib' if $^O =~ /MSWin/; WriteMakefile( %hash, 'VERSION_FROM' => 'trans.pd', ); # Add genpp rule # add other makefile additions as required (see also ExtUtils::MakeMaker) sub MY::postamble { pdlpp_postamble_int(@::pack); } PDL-LinearAlgebra-0.12/Trans/trans.pd0000644113142400244210000014424212535324057021537 0ustar chris.h.marshallDomain Usersour $VERSION = '0.12'; pp_setversion(qq{'$VERSION'}); $VERSION = eval $VERSION; use PDL::Exporter; if ($^O =~ /MSWin/) { pp_addhdr(' #include '); } pp_addhdr(' #include #if defined(PDL_CORE_VERSION) && PDL_CORE_VERSION < 10 typedef PDL_Long PDL_Indx; #endif typedef PDL_Long logical; typedef PDL_Long integer; typedef PDL_Long ftnlen; typedef struct { double r, i; } dcomplex; #ifndef abs #define abs(x) ((x) >= 0 ? (x) : -(x)) #endif #ifndef max #define max(a,b) ((a) >= (b) ? (a) : (b)) #endif #if __GLIBC__ > 1 && (defined __USE_MISC || defined __USE_XOPEN || defined __USE_ISOC9X) # define CABS(r,i) hypot (r, i) #else static double CABS (double r, double i) { double t; if (r < 0) r = - r; if (i < 0) i = - i; if (i > r) { t = r; r = i; i = t; } if (r + i == r){ return r; } t = i / r; return r * sqrt (1 + t*t); } #endif #define CSQRT(ar,ai,cr,ci) \ { \ double mag = CABS ((ar), (ai)); \ double t; \ \ if (mag == 0) \ (cr) = (ci) = 0; \ else if ((ar) > 0) \ { \ t = sqrt (0.5 * (mag + (ar))); \ (cr) = t; \ (ci) = 0.5 * (ai) / t; \ } \ else \ { \ t = sqrt (0.5 * (mag - (ar))); \ \ if ((ai) < 0) \ t = -t; \ \ (cr) = 0.5 * (ai) / t; \ (ci) = t; \ } \ } #define CMULT(ar,ai,br,bi,or,oi) \ (or) = (ar)*(br) - (ai)*(bi); \ (oi) = (ar)*(bi) + (ai)*(br); double z_abs(dcomplex *z) { return( CABS( z->r, z->i ) ); } '); pp_addpm({At=>'Top'},<<'EOD'); use PDL::Func; use PDL::Core; use PDL::Slices; use PDL::Ops qw//; use PDL::Math qw/floor/; use PDL::Complex; use PDL::NiceSlice; use PDL::LinearAlgebra; use PDL::LinearAlgebra::Real qw //; use PDL::LinearAlgebra::Complex qw //; use strict; =encoding Latin-1 =head1 NAME PDL::LinearAlgebra::Trans - Linear Algebra based transcendental functions for PDL =head1 SYNOPSIS use PDL::LinearAlgebra::Trans; $a = random (100,100); $sqrt = msqrt($a); =head1 DESCRIPTION This module provides some transcendental functions for matrices. Moreover it provides sec, asec, sech, asech, cot, acot, acoth, coth, csc, acsc, csch, acsch. Beware, importing this module will overwrite the hidden PDL routine sec. If you need to call it specify its origin module : PDL::Basic::sec(args) EOD pp_add_exported('', ' mexp mexpts mlog msqrt mpow mcos msin mtan msec mcsc mcot mcosh msinh mtanh msech mcsch mcoth macos masin matan masec macsc macot macosh masinh matanh masech macsch macoth sec asec sech asech cot acot acoth coth mfun csc acsc csch acsch toreal pi'); pp_def('geexp', Pars => '[io,phys]A(n,n);int deg();scale();[io]trace();int [o]ns();int [o]info()', GenericTypes => [D], Code => ' /* ----------------------------------------------------------------------| int dgpadm_(integer *ideg, integer *m, double *t, double *h__, integer *ldh, double *wsp, integer *lwsp, integer *ipiv, integer *iexph, integer *ns, integer *iflag) -----Purpose----------------------------------------------------------| Computes exp(t*H), the matrix exponential of a general matrix in full, using the irreducible rational Pade approximation to the exponential function exp(x) = r(x) = (+/-)( I + 2*(q(x)/p(x)) ), combined with scaling-and-squaring. -----Arguments--------------------------------------------------------| ideg|deg : (input) the degre of the diagonal Pade to be used. a value of 6 is generally satisfactory. m : (input) order of H. H|A(ldh,m): (input) argument matrix. t|scale : (input) time-scale (can be < 0). wsp|exp(lwsp) : (workspace/output) lwsp .ge. 4*m*m+ideg+1. ipiv(m) : (workspace) >>>> iexph|index : (output) number such that wsp(iexph) points to exp(tH) i.e., exp(tH) is located at wsp(iexph ... iexph+m*m-1) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ NOTE: if the routine was called with wsp(iptr), then exp(tH) will start at wsp(iptr+iexph-1). ns : (output) number of scaling-squaring used. iflag|info : (output) exit flag. 0 - no problem > 0 - Singularity in LU factorization when solving Pade approximation ----------------------------------------------------------------------| Roger B. Sidje (rbs@maths.uq.edu.au) EXPOKIT: Software Package for Computing Matrix Exponentials. ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 Gregory Vanuxem (vanuxemg@yahoo.fr) Minor modifications (Fortran to C with help of f2c, memory allocation, PDL adaptation, null entry matrix, error return, exp(tH) in entry matrix, trace normalization). ----------------------------------------------------------------------| */ extern int dscal_(integer *, double *, double *, integer *); extern int dgemm_(char *, char *, integer *, integer *, integer *, double *, double *, integer *, double *, integer *, double *, double *, integer *, ftnlen, ftnlen); extern int dgesv_(integer *, integer *, double *, integer *, integer *, double *, integer *, integer *); extern int daxpy_(integer *, double *, double *, integer *, double *, integer *); extern double dlange_(char *norm, integer *m, integer *n, double *a, integer *lda, double *work); integer i__1, i__2, i__, j, k; integer ip, mm, iq, ih2, ifree, iused, iodd, iget, iput; integer *ipiv; double cp, cq, scale, scale2, hnorm, tracen; double *coef; double *wsp; integer c__1 = 1; integer c__2 = 2; double c_b7 = 0.; double c_b11 = 1.; double c_b19 = -1.; double c_b23 = 2.; double *h__ = $P(A); $info() = 0; ///////////// mm = $PRIV(__n_size) * $PRIV(__n_size); ipiv = (integer *) malloc ( $PRIV(__n_size) * sizeof (integer)); coef = (double *) malloc ( (($deg() + 1) + $PRIV(__n_size) * $PRIV(__n_size)) * sizeof (double)); wsp = (double *) malloc ( 3 * mm * sizeof (double)); ////////// // --- initialise pointers ... ih2 = $deg() + 1; ip = 0; iq = mm; ifree = iq + mm; tracen = 0; if ($trace()) { for (i__ = 0; i__ < $PRIV(__n_size); i__++) tracen += h__[i__ + i__ * $PRIV(__n_size)]; tracen /= $PRIV(__n_size); if (tracen > 0) { for (i__ = 0; i__ < $PRIV(__n_size); i__++) h__[i__ + i__ * $PRIV(__n_size)] -= tracen; } } // --- scaling: seek ns such that ||t*H/2^ns|| < 1/2; // and set scale = t/2^ns ... // Compute Infinity norm hnorm = dlange_("I", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, $P(A), &(integer){$PRIV(__n_size)}, wsp); hnorm = abs($scale() * hnorm); if (hnorm == 0.) { free(ipiv); free(wsp); free(coef); coef = $P(A); $ns() = 0; for(i__ = 0 ; i__ < $PRIV(__n_size) ; i__++ ){ for(i__1 = 0 ; i__1 < $PRIV(__n_size) ; i__1++ ){ coef[i__1 + i__ * $PRIV(__n_size) ] = (i__ == i__1) ? 1 : 0; } } } else { i__2 = (integer ) (log(hnorm) / log(2.0) + 2); $ns() = max(0, i__2); scale = $scale() / pow(2.0, (double )$ns()); scale2 = scale * scale; // --- compute Pade coefficients ... i__ = $deg() + 1; j = ($deg() << 1) + 1; coef[0] = 1.; i__1 = $deg(); for (k = 1; k <= i__1; ++k) { coef[k] = coef[k - 1] * (double) (i__ - k) / (double) (k * (j - k)); } // --- H2 = scale2*H*H ... dgemm_("n", "n", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &scale2, h__, &(integer){$PRIV(__n_size)}, h__, &(integer){$PRIV(__n_size)}, &c_b7, &coef[ih2], &(integer){$PRIV(__n_size)}, (ftnlen)1, (ftnlen)1); // --- initialize p (numerator) and q (denominator) ... cp = coef[$deg() - 1]; cq = coef[$deg()]; for (j = 0; j < $PRIV(__n_size); j++) { for (i__ = 1; i__ <= $PRIV(__n_size); ++i__) { wsp[ip + j * $PRIV(__n_size) + i__ - 1] = 0.; wsp[iq + j * $PRIV(__n_size) + i__ - 1] = 0.; } wsp[ip + j * ($PRIV(__n_size) + 1)] = cp; wsp[iq + j * ($PRIV(__n_size) + 1)] = cq; } // --- Apply Horner rule ... iodd = 1; k = $deg() - 2; do{ iused = iodd * iq + (1 - iodd) * ip; dgemm_("n", "n", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &c_b11, &wsp[iused], &(integer){$PRIV(__n_size)}, &coef[ih2], &(integer){$PRIV(__n_size)}, &c_b7, & wsp[ifree], &(integer){$PRIV(__n_size)}, (ftnlen)1, (ftnlen)1); for (j = 0; j < $PRIV(__n_size); j++) { wsp[ifree + j * ($PRIV(__n_size) + 1)] += coef[k]; } ip = (1 - iodd) * ifree + iodd * ip; iq = iodd * ifree + (1 - iodd) * iq; ifree = iused; iodd = 1 - iodd; --k; } while (k >= 0); // --- Obtain (+/-)(I + 2*(p\q)) ... if (iodd == 1) { dgemm_("n", "n", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &scale, &wsp[iq], &(integer){$PRIV(__n_size)}, h__, &(integer){$PRIV(__n_size)}, & c_b7, &wsp[ifree], &(integer){$PRIV(__n_size)}, (ftnlen)1, (ftnlen)1); iq = ifree; } else { dgemm_("n", "n", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &scale, &wsp[ip], &(integer){$PRIV(__n_size)}, h__, &(integer){$PRIV(__n_size)}, & c_b7, &wsp[ifree], &(integer){$PRIV(__n_size)}, (ftnlen)1, (ftnlen)1); ip = ifree; } daxpy_(&mm, &c_b19, &wsp[ip], &c__1, &wsp[iq], &c__1); dgesv_(&(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &wsp[iq], &(integer){$PRIV(__n_size)}, ipiv, &wsp[ip], &(integer){$PRIV(__n_size)}, $P(info)); if ($info() != 0) { free(ipiv); free(coef); free(wsp); } else { dscal_(&mm, &c_b23, &wsp[ip], &c__1); for (j = 0; j < $PRIV(__n_size); j++) { wsp[ip + j * ($PRIV(__n_size) + 1)] += 1.; } iput = ip; if ($ns() == 0 && iodd == 1) dscal_(&mm, &c_b19, &wsp[ip], &c__1); else{ // -- squaring : exp(t*H) = (exp(t*H))^(2^ns) ... iodd = 1; i__1 = $ns(); for (k = 0; k < i__1; k++) { iget = iodd * ip + (1 - iodd) * iq; iput = (1 - iodd) * ip + iodd * iq; dgemm_("n", "n", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &c_b11, &wsp[iget], &(integer){$PRIV(__n_size)}, &wsp[iget], &(integer){$PRIV(__n_size)}, &c_b7, &wsp[iput], &(integer){$PRIV(__n_size)}, (ftnlen)1, (ftnlen)1); iodd = 1 - iodd; } } free(coef); coef = $P(A); i__2 = iput + mm; i__ = 0; $trace() = tracen; if (tracen > 0) { scale = exp(tracen); for (i__1 = iput; i__1 < i__2 ; i__1++) coef[i__++] = scale * wsp[i__1]; } else { for (i__1 = iput; i__1 < i__2 ; i__1++) coef[i__++] = wsp[i__1]; } free(wsp); free(ipiv); } } ', Doc => < 0 - Singularity in LU factorization when solving Pade approximation =for example $a = random(5,5); $trace = pdl(1); $a->xchg(0,1)->geexp(6,1,$trace, ($ns = null), ($info = null)); =cut EOT ); pp_def('cgeexp', Pars => '[io,phys]A(2,n,n);int deg();scale();int trace();int [o]ns();int [o]info()', Doc => ' =for ref Complex version of geexp. The value used for trace normalization is not returned. The algorithm is described in Roger B. Sidje (rbs@maths.uq.edu.au) "EXPOKIT: Software Package for Computing Matrix Exponentials". ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 ', GenericTypes => [D], Code => ' /* ----------------------------------------------------------------------| int dgpadm_(integer *ideg, integer *m, double *t, dcomplex *h__, integer *ldh, dcomplex *wsp, integer *lwsp, integer *ipiv, integer *iexph, integer *ns, integer *iflag) -----Purpose----------------------------------------------------------| Computes exp(t*H), the matrix exponential of a general matrix in full, using the irreducible rational Pade approximation to the exponential function exp(x) = r(x) = (+/-)( I + 2*(q(x)/p(x)) ), combined with scaling-and-squaring. -----Arguments--------------------------------------------------------| ideg|deg : (input) the degre of the diagonal Pade to be used. a value of 6 is generally satisfactory. m : (input) order of H. H|A(ldh,m): (input) argument matrix. t|scale : (input) time-scale (can be < 0). wsp|exp(lwsp) : (workspace/output) lwsp .ge. 4*m*m+ideg+1. ipiv(m) : (workspace) >>>> iexph : (output) number such that wsp(iexph) points to exp(tH) i.e., exp(tH) is located at wsp(iexph ... iexph+m*m-1) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ NOTE: if the routine was called with wsp(iptr), then exp(tH) will start at wsp(iptr+iexph-1). ns : (output) number of scaling-squaring used. iflag|info : (output) exit flag. 0 - no problem > 0 - Singularity in LU factorization when solving Pade approximation ----------------------------------------------------------------------| Roger B. Sidje (rbs@maths.uq.edu.au) EXPOKIT: Software Package for Computing Matrix Exponentials. ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 Gregory Vanuxem (vanuxemg@yahoo.fr) Minor modifications (Fortran to C with help of f2c, memory allocation, PDL adaptation, null entry matrix, error return, exp(tH) in entry matrix), trace normalization. ----------------------------------------------------------------------| */ static dcomplex c_b1 = {0.,0.}; static dcomplex c_b2 = {1.,0.}; static integer c__2 = 2; static integer c__1 = 1; static double c_b19 = 2.; static double c_b21 = -1.; integer *ipiv; integer i__1, i__2, i__3, i__, j, k; integer ip, mm, iq, ih2, iodd, iget, iput, ifree, iused; double hnorm,d__1, d__2; dcomplex scale, tracen, cp, cq, z__1; dcomplex scale2; dcomplex *wsp, *h__; extern int zgemm_(char *, char *, integer *, integer *, integer *, dcomplex *, dcomplex *, integer *, dcomplex *, integer *, dcomplex *, dcomplex *, integer *, ftnlen, ftnlen); extern int zgesv_(integer *, integer *, dcomplex *, integer *, integer *, dcomplex *, integer *, integer *); extern int zaxpy_(integer *, dcomplex *, dcomplex *, integer *, dcomplex *, integer *), zdscal_( integer *, double *, dcomplex *, integer *); extern double zlange_(char *norm, integer *m, integer *n, dcomplex *a, integer *lda, double *work); h__ = (dcomplex *) $P(A); wsp = (dcomplex *) malloc (( $deg() + 1 + 4 * $PRIV(__n_size) * $PRIV(__n_size)) * sizeof (dcomplex)); ipiv = (integer *) malloc ( $PRIV(__n_size) * sizeof (integer)); mm = $PRIV(__n_size) * $PRIV(__n_size); $info() = 0; ih2 = $deg() + 1; ip = ih2 + mm; iq = ip + mm; ifree = iq + mm; tracen.r = 0; tracen.i = 0; if ($trace()) { for (i__ = 0; i__ < $PRIV(__n_size); i__++) { tracen.r = tracen.r + h__[i__ + i__ * $PRIV(__n_size)].r; tracen.i = tracen.i + h__[i__ + i__ * $PRIV(__n_size)].i; } tracen.r = tracen.r / $PRIV(__n_size); tracen.i = tracen.i / $PRIV(__n_size); if (tracen.r < 0){ tracen.r = tracen.i; tracen.i = 0; } for (i__ = 0; i__ < $PRIV(__n_size); i__++) { h__[i__ + i__ * $PRIV(__n_size)].r = h__[i__ + i__ * $PRIV(__n_size)].r - tracen.r ; h__[i__ + i__ * $PRIV(__n_size)].i = h__[i__ + i__ * $PRIV(__n_size)].i - tracen.i ; } } // --- scaling: seek ns such that ||t*H/2^ns|| < 1/2; // and set scale = t/2^ns ... // Compute Infinity norm hnorm = zlange_("I", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &h__[0], &(integer){$PRIV(__n_size)}, &wsp[0].r); hnorm = abs($scale() * hnorm); if (hnorm == 0.) { $ns() = 0; for(i__ = 0 ; i__ < $PRIV(__n_size) ; i__++ ){ for(i__1 = 0 ; i__1 < $PRIV(__n_size) ; i__1++ ){ h__[i__1 + i__ * $PRIV(__n_size) ].r = (i__ == i__1) ? 1 : 0; h__[i__1 + i__ * $PRIV(__n_size) ].i = 0; } } } else { i__2 = (integer) ((log(hnorm) / log(2.)) + 2); $ns() = max(0,i__2); scale.r = $scale() / pow(2, (double )$ns()); scale.i = 0; scale2.r = scale.r * scale.r - scale.i * scale.i; scale2.i = scale.r * scale.i + scale.i * scale.r; // --- compute Pade coefficients ... i__ = $deg() + 1; j = ($deg() << 1) + 1; wsp[0].r = 1; wsp[0].i = 0; for (k = 1; k <= $deg(); ++k) { i__2 = k; i__3 = k - 1; d__1 = (double) (i__ - k); d__2 = (double) (k * (j - k)); wsp[i__2].r = (d__1 * wsp[i__3].r) / d__2; wsp[i__2].i = (d__1 * wsp[i__3].i) / d__2; } // --- H2 = scale2*H*H ... zgemm_("n", "n", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &scale2, &h__[0], &(integer){$PRIV(__n_size)}, &h__[0], &(integer){$PRIV(__n_size)}, &c_b1, &wsp[ih2], &(integer){$PRIV(__n_size)}, (ftnlen)1, (ftnlen)1); // --- initialise p (numerator) and q (denominator) ... i__1 = $deg() - 1; cp.r = wsp[i__1].r; cp.i = wsp[i__1].i; i__1 = $deg(); cq.r = wsp[i__1].r; cq.i = wsp[i__1].i; for (j = 0; j < $PRIV(__n_size); j++) { for (i__ = 1; i__ <= $PRIV(__n_size); ++i__) { i__3 = ip + j * $PRIV(__n_size) + i__ - 1; wsp[i__3].r = 0., wsp[i__3].i = 0.; i__3 = iq + j * $PRIV(__n_size) + i__ - 1; wsp[i__3].r = 0., wsp[i__3].i = 0.; } i__2 = ip + j * ($PRIV(__n_size) + 1); wsp[i__2].r = cp.r; wsp[i__2].i = cp.i; i__2 = iq + j * ($PRIV(__n_size) + 1); wsp[i__2].r = cq.r; wsp[i__2].i = cq.i; } // --- Apply Horner rule ... iodd = 1; k = $deg() - 2; do { iused = iodd * iq + (1 - iodd) * ip; zgemm_("n", "n", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &c_b2, &wsp[iused], &(integer){$PRIV(__n_size)}, &wsp[ih2], &(integer){$PRIV(__n_size)}, &c_b1, & wsp[ifree], &(integer){$PRIV(__n_size)}, (ftnlen)1, (ftnlen)1); for (j = 0; j < $PRIV(__n_size); j++) { i__1 = ifree + j * ($PRIV(__n_size) + 1); i__2 = ifree + j * ($PRIV(__n_size) + 1); i__3 = k; z__1.r = wsp[i__2].r + wsp[i__3].r; z__1.i = wsp[i__2].i + wsp[i__3].i; wsp[i__1].r = z__1.r; wsp[i__1].i = z__1.i; } ip = (1 - iodd) * ifree + iodd * ip; iq = iodd * ifree + (1 - iodd) * iq; ifree = iused; iodd = 1 - iodd; --k; } while(k >= 0); // --- Obtain (+/-)(I + 2*(p\q)) ... if (iodd != 0) { zgemm_("n", "n", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &scale, &wsp[iq], &(integer){$PRIV(__n_size)}, &h__[0], &(integer){$PRIV(__n_size)}, & c_b1, &wsp[ifree], &(integer){$PRIV(__n_size)}, (ftnlen)1, (ftnlen)1); iq = ifree; }else { zgemm_("n", "n", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &scale, &wsp[ip], &(integer){$PRIV(__n_size)}, &h__[0], &(integer){$PRIV(__n_size)}, & c_b1, &wsp[ifree], &(integer){$PRIV(__n_size)}, (ftnlen)1, (ftnlen)1); ip = ifree; } z__1.r = -1.; z__1.i = -0.; zaxpy_(&mm, &z__1, &wsp[ip], &c__1, &wsp[iq], &c__1); zgesv_(&(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &wsp[iq], &(integer){$PRIV(__n_size)}, ipiv, &wsp[ip], &(integer){$PRIV(__n_size)}, $P(info)); if ($info() == 0) { zdscal_(&mm, &c_b19, &wsp[ip], &c__1); for (j = 0; j < $PRIV(__n_size); j++) { i__2 = ip + j * ($PRIV(__n_size) + 1); i__3 = ip + j * ($PRIV(__n_size) + 1); wsp[i__2].r = wsp[i__3].r + 1.; wsp[i__2].i = wsp[i__3].i + 0.; } iput = ip; if ($ns() == 0 && iodd != 0) zdscal_(&mm, &c_b21, &wsp[ip], &c__1); else { // -- squaring : exp(t*H) = (exp(t*H))^(2^ns) ... iodd = 1; for (k = 0; k < $ns(); k++) { iget = iodd * ip + (1 - iodd) * iq; iput = (1 - iodd) * ip + iodd * iq; zgemm_("n", "n", &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &(integer){$PRIV(__n_size)}, &c_b2, &wsp[iget], &(integer){$PRIV(__n_size)}, &wsp[iget], &(integer){$PRIV(__n_size)}, &c_b1, &wsp[iput], &(integer){$PRIV(__n_size)}, (ftnlen)1, (ftnlen)1); iodd = 1 - iodd; } } } i__2 = iput + mm; i__ = 0; if ($trace()) { // exp(tracen) d__1 = exp(tracen.r); tracen.r = d__1 * cos(tracen.i); tracen.i = d__1 * sin(tracen.i); for (i__1 = iput; i__1 < i__2 ; i__1++) { h__[i__].r = tracen.r * wsp[i__1].r - tracen.i * wsp[i__1].i; h__[i__++].i = tracen.r * wsp[i__1].i + tracen.i * wsp[i__1].r; } } else { for (i__1 = iput; i__1 < i__2 ; i__1++) { h__[i__].r = wsp[i__1].r; h__[i__++].i = wsp[i__1].i; } } } free(wsp); free(ipiv); ', ); pp_def('ctrsqrt', Pars => '[io,phys]A(2,n,n);int uplo();[phys,o] B(2,n,n);int [o]info()', Doc => ' =for ref Root square of complex triangular matrix. Uses a recurrence of Björck and Hammarling. (See Nicholas J. Higham. A new sqrtm for MATLAB. Numerical Analysis Report No. 336, Manchester Centre for Computational Mathematics, Manchester, England, January 1999. It\'s available at http://www.ma.man.ac.uk/~higham/pap-mf.html) If uplo is true, A is lower triangular. ', GenericTypes => [D], Code => ' dcomplex *cb, *ca; dcomplex s, snum, sdenum; double *b; double tt, dn; integer i, j, k, l, ind, ind1, ind2; ca = (dcomplex *) $P(A); b = $P(B); cb = (dcomplex *) $P(B); #define subscr(a_1,a_2)\ ($uplo()) ? (a_2) * $PRIV(__n_size) + (a_1) : (a_1) * $PRIV(__n_size) + (a_2) $info() = 0; ind = $PRIV(__n_size) * $PRIV(__n_size) * 2; for (i = 0; i < ind;i++) b[i] = 0; for (i = 0; i < $PRIV(__n_size); i++){ ind = subscr(i,i); CSQRT(ca[ind].r, ca[ind].i, cb[ind].r, cb[ind].i) } for (k = 0; k < $PRIV(__n_size)-1; k++) { for (i = 0; i < $PRIV(__n_size)-(k+1); i++) { j = i + k + 1; ind = subscr(i,j); s.r = 0; s.i = 0; for (l = i+1; l < j; l++) { ind1 = subscr(i,l); ind2 = subscr(l,j); s.r += cb[ind1].r * cb[ind2].r - cb[ind1].i * cb[ind2].i; s.i += cb[ind1].r * cb[ind2].i + cb[ind1].i * cb[ind2].r; } ind1 = subscr(i,i); ind2 = subscr(j,j); sdenum.r = cb[ind1].r + cb[ind2].r; sdenum.i = cb[ind1].i + cb[ind2].i; snum.r = ca[ind].r - s.r; snum.i = ca[ind].i - s.i; if (fabs (sdenum.r) > fabs (sdenum.i)) { if (sdenum.r == 0){ $info() = -1; goto ENDCTRSQRT; } tt = sdenum.i / sdenum.r; dn = sdenum.r + tt * sdenum.i; cb[ind].r = (snum.r + tt * snum.i) / dn; cb[ind].i = (snum.i - tt * snum.r) / dn; } else { if (sdenum.i == 0){ $info() = -1; goto ENDCTRSQRT; } tt = sdenum.r / sdenum.i; dn = sdenum.r * tt + sdenum.i; cb[ind].r = (snum.r * tt + snum.i) / dn; cb[ind].i = (snum.i * tt - snum.r) / dn; } } } ENDCTRSQRT: ; #undef subscr ', ); pp_addhdr(' void dfunc_wrapper(dcomplex *p, integer n, SV* dfunc) { dSP ; int count; SV *pdl1; HV *bless_stash; pdl *pdl; PDL_Indx odims[1]; PDL_Indx dims[] = {2,n}; pdl = PDL->pdlnew(); PDL->setdims (pdl, dims, 2); pdl->datatype = PDL_D; pdl->data = (double *) &p[0].r; pdl->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; bless_stash = gv_stashpv("PDL::Complex", 0); ENTER ; SAVETMPS ; PUSHMARK(sp) ; pdl1 = sv_newmortal(); PDL->SetSV_PDL(pdl1, pdl); pdl1 = sv_bless(pdl1, bless_stash); /* bless in PDL::Complex */ XPUSHs(pdl1); PUTBACK ; count = perl_call_sv(dfunc, G_SCALAR); SPAGAIN; // For pdl_free odims[0] = 0; PDL->setdims (pdl, odims, 0); pdl->state &= ~ (PDL_ALLOCATED |PDL_DONTTOUCHDATA); pdl->data=NULL; if (count !=1) croak("Error calling perl function\n"); PUTBACK ; FREETMPS ; LEAVE ; } '); pp_def('ctrfun', Pars => '[io,phys]A(2,n,n);int uplo();[phys,o] B(2,n,n);int [o]info()', OtherPars => "SV* func" , Doc => ' =for ref Apply an arbitrary function to a complex triangular matrix. Uses a recurrence of Parlett. If uplo is true, A is lower triangular. ', GenericTypes => [D], Code => ' dcomplex *cb, *ca, *diag; dcomplex s, snum, sdenum; double *b; double tt, dn; integer i, j, k, l, p, ind, ind1, ind2, tmp, c__1; extern double zdotu_(double *ret, integer *n, double *dx, integer *incx, double *dy, integer *incy); diag = (dcomplex *) malloc ($PRIV(__n_size) * sizeof(dcomplex)); ca = (dcomplex *) $P(A); b = $P(B); cb = (dcomplex *) $P(B); c__1 = 1; #define subscr(a_1,a_2) \ ( $uplo() ) ? (a_2)+ $PRIV(__n_size) * (a_1) : (a_1)+ $PRIV(__n_size) * (a_2) $info() = 0; ind = $PRIV(__n_size) * $PRIV(__n_size) * 2; for (i = 0; i < ind;i++) b[i] = 0; for (i = 0; i < $PRIV(__n_size);i++) { ind = subscr(i,i); diag[i].r = ca[ind].r; diag[i].i = ca[ind].i; } dfunc_wrapper(diag, $PRIV(__n_size), $PRIV(func)); for (i = 0; i < $PRIV(__n_size); i++) { ind = subscr(i,i); cb[ind].r = diag[i].r; cb[ind].i = diag[i].i; } for (p = 1; p < $PRIV(__n_size); p++) { tmp = $PRIV(__n_size) - p; for (i = 0; i < tmp; i++) { j = i + p; //$s = $T(,($j),($i))->Cmul($F(,($j),($j))->Csub($F(,($i),($i)))); ind1 = subscr(i,i); ind2 = subscr(j,j); s.r = cb[ind2].r - cb[ind1].r; s.i = cb[ind2].i - cb[ind1].i; ind = subscr(j,i); CMULT(ca[ind].r, ca[ind].i, s.r, s.i, snum.r, snum.i) s.r = snum.r; s.i = snum.i; if (i < (j-1)) { //$s = $s + $T(,$i+1:$j-1,($i))->cdot(1, $F(,($j), $i+1:$j-1),1)->Csub($F(,$i+1:$j-1,($i))->cdot(1,$T(,($j), $i+1:$j-1),1)); // $T(,$i+1:$j-1,($i))->cdot(1, $F(,($j), $i+1:$j-1),1) l = 0; for(k = i+1; k < j; k++) { ind = subscr(j,k); diag[l].r = cb[ind].r; diag[l++].i = cb[ind].i; } ind = subscr(i+1,i); // TODO : Humm zdotu_(&s.r, &l, &ca[ind].r, &c__1, &diag[0].r, &c__1); snum.r += s.r; snum.i += s.i; // $F(,$i+1:$j-1,($i))->cdot(1,$T(,($j), $i+1:$j-1),1) l = 0; for(k = i+1; k < j; k++) { ind = subscr(j,k); diag[l].r = ca[ind].r; diag[l++].i = ca[ind].i; } ind = subscr(i+1,i); // TODO : Humm zdotu_(&s.r, &l, &cb[ind].r, &c__1, &diag[0].r, &c__1); snum.r -= s.r; snum.i -= s.i; ind = subscr(j,i); } //$sdenum = $T(,($j),($j))->Csub($T(,($i),($i))); sdenum.r = ca[ind2].r - ca[ind1].r; sdenum.i = ca[ind2].i - ca[ind1].i; //$s = $s / $sdenum; if (fabs (sdenum.r) > fabs (sdenum.i)) { if (sdenum.r == 0) { $info() = -1; goto ENDCTRFUN; } tt = sdenum.i / sdenum.r; dn = sdenum.r + tt * sdenum.i; cb[ind].r = (snum.r + tt * snum.i) / dn; cb[ind].i = (snum.i - tt * snum.r) / dn; } else { if (sdenum.i == 0) { $info() = -1; goto ENDCTRFUN; } tt = sdenum.r / sdenum.i; dn = sdenum.r * tt + sdenum.i; cb[ind].r = (snum.r * tt + snum.i) / dn; cb[ind].i = (snum.i * tt - snum.r) / dn; } } } ENDCTRFUN: ; #undef subscr ', ); pp_addpm(<<'EOD'); my $pi; BEGIN { $pi = pdl(3.1415926535897932384626433832795029) } sub pi () { $pi->copy }; *sec = \&PDL::sec; sub PDL::sec{1/cos($_[0])} *csc = \&PDL::csc; sub PDL::csc($) {1/sin($_[0])} *cot = \&PDL::cot; sub PDL::cot($) {1/(sin($_[0])/cos($_[0]))} *sech = \&PDL::sech; sub PDL::sech($){1/pdl($_[0])->cosh} *csch = \&PDL::csch; sub PDL::csch($) {1/pdl($_[0])->sinh} *coth = \&PDL::coth; sub PDL::coth($) {1/pdl($_[0])->tanh} *asec = \&PDL::asec; sub PDL::asec($) {my $tmp = 1/pdl($_[0]) ; $tmp->acos} *acsc = \&PDL::acsc; sub PDL::acsc($) {my $tmp = 1/pdl($_[0]) ; $tmp->asin} *acot = \&PDL::acot; sub PDL::acot($) {my $tmp = 1/pdl($_[0]) ; $tmp->atan} *asech = \&PDL::asech; sub PDL::asech($) {my $tmp = 1/pdl($_[0]) ; $tmp->acosh} *acsch = \&PDL::acsch; sub PDL::acsch($) {my $tmp = 1/pdl($_[0]) ; $tmp->asinh} *acoth = \&PDL::acoth; sub PDL::acoth($) {my $tmp = 1/pdl($_[0]) ; $tmp->atanh} my $_tol = 9.99999999999999e-15; sub toreal{ return $_[0] if $_[0]->isempty; $_tol = $_[1] if defined $_[1]; my ($min, $max, $tmp); ($min, $max) = $_[0]->slice('(1)')->minmax; return re($_[0])->sever unless (abs($min) > $_tol || abs($max) > $_tol); $_[0]; } =head2 mlog =for ref Return matrix logarithm of a square matrix. =for usage PDL = mlog(PDL(A)) =for example my $a = random(10,10); my $log = mlog($a); =cut *mlog = \&PDL::mlog; sub PDL::mlog { my ($m, $tol) = @_; my @dims = $m->dims; barf("mlog requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); mfun($m, sub{$_[0].=log $_[0]} , 0, $tol); } =head2 msqrt =for ref Return matrix square root (principal) of a square matrix. =for usage PDL = msqrt(PDL(A)) =for example my $a = random(10,10); my $sqrt = msqrt($a); =cut *msqrt = \&PDL::msqrt; sub PDL::msqrt { my ($m, $tol) = @_; my @dims = $m->dims; barf("msqrt requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); $m = $m->r2C unless @dims == 3; my ($t, undef, $z, undef, $info) = $m->mschur(1); if ($info){ warn "msqrt: Can't compute Schur form\n"; return; } ($t, $info) = $t->ctrsqrt(0); if($info){ warn "msqrt: can't compute square root\n"; return; } $m = $z x $t x $z->t(1); return (@dims ==3) ? $m : toreal($m, $tol); } =head2 mexp =for ref Return matrix exponential of a square matrix. =for usage PDL = mexp(PDL(A)) =for example my $a = random(10,10); my $exp = mexp($a); =cut *mexp = \&PDL::mexp; sub PDL::mexp { my ($m, $order, $trace) = @_; my @dims = $m->dims; barf("mexp requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($info, $ns); $info = PDL::null; $ns = PDL::null; $trace = 1 unless defined $trace; $order = 6 unless defined $order; $m = $m->copy; @dims == 3 ? $m->xchg(1,2)->cgeexp($order, 1, $trace, $ns, $info) : $m->xchg(0,1)->geexp($order, 1, $trace, $ns, $info); if ($info){ warn "mexp: Error $info"; } else{ return $m; } } #*mexp2 = \&PDL::mexp2; #sub PDL::mexp2 { # my ($m, $order) = @_; # my @dims = $m->dims; # barf("mexp requires a 2-D square matrix") # unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); # my ($norm, $X, $c, $D, $N, $fact, $cX, $trace); # if (defined $order){ # $order++; # } # else{ # $order = 8; # } # Trace normalization # $m = $m->copy; # $trace = $m->diag->sumover / $m->dim(1); # if (@dims == 3){ # $trace = $trace->im->r2C if ($trace->re < 0); # $m->diagonal(1,2) .= $m->diagonal(1,2) - $trace; # } # elsif ($trace > 0){ # $m->diagonal(0,1) -= $trace; # } # Scale M # $norm = $m->mnorm(0); # $norm = $norm > 0 ? PDL::floor(1 + ($norm->log / log(2))) : 0; # $norm = 0 unless $norm > 0; # $m = $m / 2**$norm if $norm > 0; # $X = $m; # $N = $m / 2; # $D = -$m / 2; # $c = 0.5; # if (@dims == 3){ # $N->re->diagonal(0,1)++; # $D->re->diagonal(0,1)++; # } # else{ # $N->diagonal(0,1)++; # $D->diagonal(0,1)++; # } # # for ($fact = 2; $fact <= $order;$fact++){ # # Padé coeff # $c = $c * ($order - $fact + 1 ) / ($fact * (2 * $order - $fact +1)); # # if (@dims == 3){ # $X = PDL::cmmult($m, $X); # $cX = PDL::Complex::Cmul($X, PDL::Complex::r2C(PDL->pdl($c))); # } # else{ # $X = PDL::mmult($m, $X); # $cX = PDL::mult($X, PDL->pdl($c),0); # } # $N = PDL::plus($N,$cX,0); # $D = ($fact % 2) ? PDL::minus($D,$cX,0) : # PDL::plus($D,$cX,0); # } # # $X = PDL::msolvex($D,$N, equilibrate=>1); # # # Squaring # if($norm > 0){ # for(1..$norm){ # $X x= $X; # } # } # # # Reverse trace normalization # $X = $trace->exp * $X if (@dims == 3 || $trace > 0); # $X; #} *mexpts = \&PDL::mexpts; sub PDL::mexpts { my ($m, $order, $tol) = @_; my @dims = $m->dims; barf("mexp1 requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($em, $trm); $order = 20 unless defined $order; $em = (@dims == 3 ) ? diag(r2C ones($dims[1])) : diag(ones($dims[1])); $trm = $em->copy; for (1..($order - 1)){ $trm = $trm x ($m / $_); $em += $trm; } return (@dims ==3) ? $em : toreal($em, $tol); } =head2 mpow =for ref Return matrix power of a square matrix. =for usage PDL = mpow(PDL(A), SCALAR(exponent)) =for example my $a = random(10,10); my $powered = mpow($a,2.5); =cut #TODO: improve it (really crappy) *mpow = \&PDL::mpow; sub PDL::mpow { my ($m, $power, $tol, $eigen) = @_; my @dims = $m->dims; barf("mpow requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my $ret; if (UNIVERSAL::isa($power,'PDL') and $power->dims > 1){ my ($e, $v) = $m->meigen(0,1); $ret = $v * $e->Cpow($power) x $v->minv; } elsif( 1/$dims[-1] * 1000 > abs($power) and !$eigen){ $ret = $m; my $pow = floor($power); $pow++ if ($power < 0 and $power != $pow); # TODO: what a beautiful thing (is it a game ?) for(my $i = 1; $i < abs($pow); $i++){ $ret x= $m;} $ret = $ret->minv if $power < 0; if ($power = $power - $pow){ if($power == 0.5){ my $v = $m->msqrt; $ret = ($pow == 0) ? $v : $ret x $v; } else{ my ($e, $v) = $m->meigen(0,1); $ret = ($pow == 0) ? ($v * $e**$power x $v->minv) : $ret->r2C x ($v * $e**$power x $v->minv); } } } else{ my ($e, $v) = $m->meigen(0,1); $ret = $v * $e**$power x $v->minv; } return (@dims ==3) ? $ret : toreal($ret, $tol); } =head2 mcos =for ref Return matrix cosine of a square matrix. =for usage PDL = mcos(PDL(A)) =for example my $a = random(10,10); my $cos = mcos($a); =cut *mcos = \&PDL::mcos; sub PDL::mcos { my $m = shift; my @dims = $m->dims; barf("mcos requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return (@dims == 3) ? (mexp(i*$m) + mexp(- i*$m)) / 2 : re(mexp(i*$m))->sever; } =head2 macos =for ref Return matrix inverse cosine of a square matrix. =for usage PDL = macos(PDL(A)) =for example my $a = random(10,10); my $acos = macos($a); =cut *macos = \&PDL::macos; sub PDL::macos { my ($m, $tol) = @_; my @dims = $m->dims; barf("macos requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($id, $ret); $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $ret = i * mlog( ($m->r2C - i * msqrt( ($id - $m x $m), $tol))); return (@dims ==3) ? $ret : toreal($ret, $tol); } =head2 msin =for ref Return matrix sine of a square matrix. =for usage PDL = msin(PDL(A)) =for example my $a = random(10,10); my $sin = msin($a); =cut *msin = \&PDL::msin; sub PDL::msin { my $m = shift; my @dims = $m->dims; barf("msin requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return (@dims == 3) ? (mexp(i*$m) - mexp(- i*$m))/(2*i) : im(mexp(i*$m))->sever; } =head2 masin =for ref Return matrix inverse sine of a square matrix. =for usage PDL = masin(PDL(A)) =for example my $a = random(10,10); my $asin = masin($a); =cut *masin = \&PDL::masin; sub PDL::masin { my ($m, $tol) = @_; my @dims = $m->dims; barf("masin requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($ret, $id); $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $ret = (- i) * mlog(((i*$m) + msqrt($id - $m x $m, $tol))); return (@dims ==3) ? $ret : toreal($ret, $tol); } =head2 mtan =for ref Return matrix tangent of a square matrix. =for usage PDL = mtan(PDL(A)) =for example my $a = random(10,10); my $tan = mtan($a); =cut *mtan = \&PDL::mtan; sub PDL::mtan { my ($m, $id) = @_; my @dims = $m->dims; barf("mtan requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return scalar msolvex(mcos($m), msin($m),equilibrate=>1) unless $id; if (@dims == 3){ $id = PDL::zeroes $m; $id->slice('(0),:,:')->diagonal(0,1) .= 1; $m = mexp(-2*i*$m); return scalar msolvex( ($id + $m ),( (- i) * ($id - $m)),equilibrate=>1); } else{ $m = mexp(i * $m); return scalar $m->re->msolvex($m->im,equilibrate=>1); } } =head2 matan =for ref Return matrix inverse tangent of a square matrix. =for usage PDL = matan(PDL(A)) =for example my $a = random(10,10); my $atan = matan($a); =cut *matan = \&PDL::matan; sub PDL::matan { my ($m, $tol) = @_; my @dims = $m->dims; barf("matan requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($id, $ret); $id = PDL::zeroes($m)->r2C; $id->re->diagonal(0,1) .= 1; $ret = - i/2 * mlog( scalar PDL::msolvex( ($id - i*$m) ,($id + i*$m),equilibrate=>1 )); return (@dims ==3) ? $ret : toreal($ret, $tol); } =head2 mcot =for ref Return matrix cotangent of a square matrix. =for usage PDL = mcot(PDL(A)) =for example my $a = random(10,10); my $cot = mcot($a); =cut *mcot = \&PDL::mcot; sub PDL::mcot { my ($m, $id) = @_; my @dims = $m->dims; barf("mcot requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return scalar msolvex(msin($m),mcos($m),equilibrate=>1) unless $id; if (@dims == 3){ $id = PDL::zeroes $m; $id->slice('(0),:,:')->diagonal(0,1) .= 1; $m = mexp(-2*i*$m); return scalar msolvex( ($id - $m ),( i * ($id + $m)),equilibrate=>1); } else{ $m = mexp(i * $m); return scalar $m->im->msolvex($m->re,equilibrate=>1); } } =head2 macot =for ref Return matrix inverse cotangent of a square matrix. =for usage PDL = macot(PDL(A)) =for example my $a = random(10,10); my $acot = macot($a); =cut *macot = \&PDL::macot; sub PDL::macot { my ($m, $tol, $id) = @_; my @dims = $m->dims; barf("macot requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "macot: singular matrix"; return; } return matan($inv,$tol); } =head2 msec =for ref Return matrix secant of a square matrix. =for usage PDL = msec(PDL(A)) =for example my $a = random(10,10); my $sec = msec($a); =cut *msec = \&PDL::msec; sub PDL::msec { my $m = shift; my @dims = $m->dims; barf("msec requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return (@dims == 3) ? PDL::minv(mexp(i+$m) + mexp(- i*$m)) * 2 : scalar PDL::minv(re(mexp(i*$m))); } =head2 masec =for ref Return matrix inverse secant of a square matrix. =for usage PDL = masec(PDL(A)) =for example my $a = random(10,10); my $asec = masec($a); =cut *masec = \&PDL::masec; sub PDL::masec { my ($m, $tol) = @_; my @dims = $m->dims; barf("masec requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "masec: singular matrix"; return; } return macos($inv,$tol); } =head2 mcsc =for ref Return matrix cosecant of a square matrix. =for usage PDL = mcsc(PDL(A)) =for example my $a = random(10,10); my $csc = mcsc($a); =cut *mcsc = \&PDL::mcsc; sub PDL::mcsc { my $m = shift; my @dims = $m->dims; barf("mcsc requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return (@dims == 3) ? PDL::minv(mexp(i*$m) - mexp(- i*$m)) * 2*i : scalar PDL::minv(im(mexp(i*$m))); } =head2 macsc =for ref Return matrix inverse cosecant of a square matrix. =for usage PDL = macsc(PDL(A)) =for example my $a = random(10,10); my $acsc = macsc($a); =cut *macsc = \&PDL::macsc; sub PDL::macsc { my ($m, $tol) = @_; my @dims = $m->dims; barf("macsc requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "macsc: singular matrix"; return; } return masin($inv,$tol); } =head2 mcosh =for ref Return matrix hyperbolic cosine of a square matrix. =for usage PDL = mcosh(PDL(A)) =for example my $a = random(10,10); my $cos = mcosh($a); =cut *mcosh = \&PDL::mcosh; sub PDL::mcosh { my $m = shift; my @dims = $m->dims; barf("mcosh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); ( $m->mexp + mexp(-$m) )/2; } =head2 macosh =for ref Return matrix hyperbolic inverse cosine of a square matrix. =for usage PDL = macosh(PDL(A)) =for example my $a = random(10,10); my $acos = macosh($a); =cut *macosh = \&PDL::macosh; sub PDL::macosh { my ($m, $tol) = @_; my @dims = $m->dims; barf("macosh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($id, $ret); $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $ret = msqrt($m x $m - $id); $m = $m->r2C if $ret->getndims > @dims; mlog($m + $ret, $tol); } =head2 msinh =for ref Return matrix hyperbolic sine of a square matrix. =for usage PDL = msinh(PDL(A)) =for example my $a = random(10,10); my $sinh = msinh($a); =cut *msinh = \&PDL::msinh; sub PDL::msinh { my $m = shift; my @dims = $m->dims; barf("msinh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); ( $m->mexp - mexp(-$m) )/2; } =head2 masinh =for ref Return matrix hyperbolic inverse sine of a square matrix. =for usage PDL = masinh(PDL(A)) =for example my $a = random(10,10); my $asinh = masinh($a); =cut *masinh = \&PDL::masinh; sub PDL::masinh { my ($m, $tol) = @_; my @dims = $m->dims; barf("masinh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($id, $ret); $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $ret = msqrt($m x $m + $id); $m = $m->r2C if $ret->getndims > @dims; mlog(($m + $ret), $tol); } =head2 mtanh =for ref Return matrix hyperbolic tangent of a square matrix. =for usage PDL = mtanh(PDL(A)) =for example my $a = random(10,10); my $tanh = mtanh($a); =cut *mtanh = \&PDL::mtanh; sub PDL::mtanh { my ($m, $id) = @_; my @dims = $m->dims; barf("mtanh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); return scalar msolvex(mcosh($m), msinh($m),equilibrate=>1) unless $id; $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $m = mexp(-2*$m); return scalar msolvex( ($id + $m ),($id - $m), equilibrate=>1); } =head2 matanh =for ref Return matrix hyperbolic inverse tangent of a square matrix. =for usage PDL = matanh(PDL(A)) =for example my $a = random(10,10); my $atanh = matanh($a); =cut *matanh = \&PDL::matanh; sub PDL::matanh { my ($m, $tol) = @_; my @dims = $m->dims; barf("matanh requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($id, $ret); $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; mlog( scalar msolvex( ($id - $m ),($id + $m),equilibrate=>1), $tol ) / 2; } =head2 mcoth =for ref Return matrix hyperbolic cotangent of a square matrix. =for usage PDL = mcoth(PDL(A)) =for example my $a = random(10,10); my $coth = mcoth($a); =cut *mcoth = \&PDL::mcoth; sub PDL::mcoth { my ($m, $id) = @_; my @dims = $m->dims; barf("mcoth requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); scalar msolvex(msinh($m), mcosh($m),equilibrate=>1) unless $id; $id = PDL::zeroes $m; (@dims == 3) ? $id->slice('(0),:,:')->diagonal(0,1) .= 1 : $id->diagonal(0,1) .= 1; $m = mexp(-2*$m); return scalar msolvex( ($id - $m ),($id + $m),equilibrate=>1); } =head2 macoth =for ref Return matrix hyperbolic inverse cotangent of a square matrix. =for usage PDL = macoth(PDL(A)) =for example my $a = random(10,10); my $acoth = macoth($a); =cut *macoth = \&PDL::macoth; sub PDL::macoth { my ($m, $tol) = @_; my @dims = $m->dims; barf("macoth requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "macoth: singular matrix"; return; } return matanh($inv,$tol); } =head2 msech =for ref Return matrix hyperbolic secant of a square matrix. =for usage PDL = msech(PDL(A)) =for example my $a = random(10,10); my $sech = msech($a); =cut *msech = \&PDL::msech; sub PDL::msech { my $m = shift; my @dims = $m->dims; barf("msech requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); PDL::minv( $m->mexp + mexp(-$m) ) * 2; } =head2 masech =for ref Return matrix hyperbolic inverse secant of a square matrix. =for usage PDL = masech(PDL(A)) =for example my $a = random(10,10); my $asech = masech($a); =cut *masech = \&PDL::masech; sub PDL::masech { my ($m, $tol) = @_; my @dims = $m->dims; barf("masech requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "masech: singular matrix"; return; } return macosh($inv,$tol); } =head2 mcsch =for ref Return matrix hyperbolic cosecant of a square matrix. =for usage PDL = mcsch(PDL(A)) =for example my $a = random(10,10); my $csch = mcsch($a); =cut *mcsch = \&PDL::mcsch; sub PDL::mcsch { my $m = shift; my @dims = $m->dims; barf("mcsch requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); PDL::minv( $m->mexp - mexp(-$m) ) * 2; } =head2 macsch =for ref Return matrix hyperbolic inverse cosecant of a square matrix. =for usage PDL = macsch(PDL(A)) =for example my $a = random(10,10); my $acsch = macsch($a); =cut *macsch = \&PDL::macsch; sub PDL::macsch { my ($m, $tol) = @_; my @dims = $m->dims; barf("macsch requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); my ($inv, $info) = $m->minv; if ($info){ warn "macsch: singular matrix"; return; } return masinh($inv,$tol); } =head2 mfun =for ref Return matrix function of second argument of a square matrix. Function will be applied on a PDL::Complex object. =for usage PDL = mfun(PDL(A),'cos') =for example my $a = random(10,10); my $fun = mfun($a,'cos'); sub sinbycos2{ $_[0]->set_inplace(0); $_[0] .= $_[0]->Csin/$_[0]->Ccos**2; } # Try diagonalization $fun = mfun($a, \&sinbycos2,1); # Now try Schur/Parlett $fun = mfun($a, \&sinbycos2); # Now with function. scalar msolve($a->mcos->mpow(2), $a->msin); =cut *mfun = \&PDL::mfun; sub PDL::mfun { my ($m, $method, $diag, $tol) = @_; my @dims = $m->dims; barf("mfun requires a 2-D square matrix") unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); if ($diag){ my ($e, $v, $inv, $info); ($e, $v) = $m->meigen(0,1); ($inv, $info) = $v->minv; unless ($info){ $method = 'PDL::Complex::'.$method unless ref($method); eval {$v = ($v * $e->$method) x $v->minv;}; if ($@){ warn "mfun: Error $@\n"; return; } } else{ warn "mfun: Non invertible matrix in computation of $method\n"; return; } return (@dims ==3) ? $v : toreal($v, $tol); } else{ $m = $m->r2C unless @dims == 3; my ($t, undef, $z, undef, $info) = $m->mschur(1); if ($info){ warn "mfun: Can't compute Schur form\n"; return; } $method = 'PDL::Complex::'.$method unless ref($method); ($t, $info) = $t->ctrfun(0,$method); if($info){ warn "mfun: Can't compute $method\n"; return; } $m = $z x $t x $z->t(1); return (@dims ==3) ? $m : toreal($m, $tol); } } #*mspfun = \&PDL::mspfun; #sub PDL::mspfun { # my ($m, $method, $tol) = @_; # my @dims = $m->dims; # barf("mspfun requires a 2-D square matrix") # unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); # my ($T, $Z, $F, $p, $i, $j, $sden, $s ); # ($T, undef, $Z) = $m->r2C->mschur(1); # $F = $T->diagonal(1,2)->$method->diag; # for $p (1..($dims[-1] - 1 )){ # for $i (0..($dims[-1]-$p-1)){ # $j = $i + $p; # $s = $T(,($j),($i))->Cmul($F(,($j),($j))->Csub($F(,($i),($i)))); # if ($i < ($j-1)){ # $s = $s + $T(,$i+1:$j-1,($i))->cdot(1, $F(,($j), $i+1:$j-1),1)->Csub($F(,$i+1:$j-1,($i))->cdot(1,$T(,($j), $i+1:$j-1),1)); # } # $sden = $T(,($j),($j))->Csub($T(,($i),($i))); # if ($sden != 0){ # $s = $s / $sden; # } # else{ # barf "Illegal division by zero occured\n"; # } # $F(,($j),($i)) .= $s; # } # } # print $F; # $m = $Z x $F x $Z->t(1); # return (@dims ==3) ? $m : toreal($m, $tol); # #} =head1 TODO Improve error return and check singularity. Improve (msqrt,mlog) / r2C =head1 AUTHOR Copyright (C) Grégory Vanuxem 2005-2007. This library is free software; you can redistribute it and/or modify it under the terms of the artistic license as specified in the Artistic file. =cut EOD pp_done(); 1;