ruby-lapack 1.3

data/ext/dgejsv.c

@@ -0,0 +1,155 @@
+#include "rb_lapack.h"
+
+extern VOID dgejsv_(char* joba, char* jobu, char* jobv, char* jobr, char* jobt, char* jobp, integer* m, integer* n, doublereal* a, integer* lda, doublereal* sva, doublereal* u, integer* ldu, doublereal* v, integer* ldv, doublereal* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgejsv(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_joba;
+  char joba; 
+  VALUE rblapack_jobu;
+  char jobu; 
+  VALUE rblapack_jobv;
+  char jobv; 
+  VALUE rblapack_jobr;
+  char jobr; 
+  VALUE rblapack_jobt;
+  char jobt; 
+  VALUE rblapack_jobp;
+  char jobp; 
+  VALUE rblapack_m;
+  integer m; 
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_work;
+  doublereal *work; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_sva;
+  doublereal *sva; 
+  VALUE rblapack_u;
+  doublereal *u; 
+  VALUE rblapack_v;
+  doublereal *v; 
+  VALUE rblapack_iwork;
+  integer *iwork; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_work_out__;
+  doublereal *work_out__;
+
+  integer lda;
+  integer n;
+  integer ldu;
+  integer ldv;
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  sva, u, v, iwork, info, work = NumRu::Lapack.dgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEJSV computes the singular value decomposition (SVD) of a real M-by-N\n*  matrix [A], where M >= N. The SVD of [A] is written as\n*\n*               [A] = [U] * [SIGMA] * [V]^t,\n*\n*  where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N\n*  diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and\n*  [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are\n*  the singular values of [A]. The columns of [U] and [V] are the left and\n*  the right singular vectors of [A], respectively. The matrices [U] and [V]\n*  are computed and stored in the arrays U and V, respectively. The diagonal\n*  of [SIGMA] is computed and stored in the array SVA.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBA    (input) CHARACTER*1\n*        Specifies the level of accuracy:\n*       = 'C': This option works well (high relative accuracy) if A = B * D,\n*             with well-conditioned B and arbitrary diagonal matrix D.\n*             The accuracy cannot be spoiled by COLUMN scaling. The\n*             accuracy of the computed output depends on the condition of\n*             B, and the procedure aims at the best theoretical accuracy.\n*             The relative error max_{i=1:N}|d sigma_i| / sigma_i is\n*             bounded by f(M,N)*epsilon* cond(B), independent of D.\n*             The input matrix is preprocessed with the QRF with column\n*             pivoting. This initial preprocessing and preconditioning by\n*             a rank revealing QR factorization is common for all values of\n*             JOBA. Additional actions are specified as follows:\n*       = 'E': Computation as with 'C' with an additional estimate of the\n*             condition number of B. It provides a realistic error bound.\n*       = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings\n*             D1, D2, and well-conditioned matrix C, this option gives\n*             higher accuracy than the 'C' option. If the structure of the\n*             input matrix is not known, and relative accuracy is\n*             desirable, then this option is advisable. The input matrix A\n*             is preprocessed with QR factorization with FULL (row and\n*             column) pivoting.\n*       = 'G'  Computation as with 'F' with an additional estimate of the\n*             condition number of B, where A=D*B. If A has heavily weighted\n*             rows, then using this condition number gives too pessimistic\n*             error bound.\n*       = 'A': Small singular values are the noise and the matrix is treated\n*             as numerically rank defficient. The error in the computed\n*             singular values is bounded by f(m,n)*epsilon*||A||.\n*             The computed SVD A = U * S * V^t restores A up to\n*             f(m,n)*epsilon*||A||.\n*             This gives the procedure the licence to discard (set to zero)\n*             all singular values below N*epsilon*||A||.\n*       = 'R': Similar as in 'A'. Rank revealing property of the initial\n*             QR factorization is used do reveal (using triangular factor)\n*             a gap sigma_{r+1} < epsilon * sigma_r in which case the\n*             numerical RANK is declared to be r. The SVD is computed with\n*             absolute error bounds, but more accurately than with 'A'.\n*\n*  JOBU    (input) CHARACTER*1\n*        Specifies whether to compute the columns of U:\n*       = 'U': N columns of U are returned in the array U.\n*       = 'F': full set of M left sing. vectors is returned in the array U.\n*       = 'W': U may be used as workspace of length M*N. See the description\n*             of U.\n*       = 'N': U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*        Specifies whether to compute the matrix V:\n*       = 'V': N columns of V are returned in the array V; Jacobi rotations\n*             are not explicitly accumulated.\n*       = 'J': N columns of V are returned in the array V, but they are\n*             computed as the product of Jacobi rotations. This option is\n*             allowed only if JOBU .NE. 'N', i.e. in computing the full SVD.\n*       = 'W': V may be used as workspace of length N*N. See the description\n*             of V.\n*       = 'N': V is not computed.\n*\n*  JOBR    (input) CHARACTER*1\n*        Specifies the RANGE for the singular values. Issues the licence to\n*        set to zero small positive singular values if they are outside\n*        specified range. If A .NE. 0 is scaled so that the largest singular\n*        value of c*A is around DSQRT(BIG), BIG=SLAMCH('O'), then JOBR issues\n*        the licence to kill columns of A whose norm in c*A is less than\n*        DSQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN,\n*        where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E').\n*       = 'N': Do not kill small columns of c*A. This option assumes that\n*             BLAS and QR factorizations and triangular solvers are\n*             implemented to work in that range. If the condition of A\n*             is greater than BIG, use DGESVJ.\n*       = 'R': RESTRICTED range for sigma(c*A) is [DSQRT(SFMIN), DSQRT(BIG)]\n*             (roughly, as described above). This option is recommended.\n*                                            ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n*        For computing the singular values in the FULL range [SFMIN,BIG]\n*        use DGESVJ.\n*\n*  JOBT    (input) CHARACTER*1\n*        If the matrix is square then the procedure may determine to use\n*        transposed A if A^t seems to be better with respect to convergence.\n*        If the matrix is not square, JOBT is ignored. This is subject to\n*        changes in the future.\n*        The decision is based on two values of entropy over the adjoint\n*        orbit of A^t * A. See the descriptions of WORK(6) and WORK(7).\n*       = 'T': transpose if entropy test indicates possibly faster\n*        convergence of Jacobi process if A^t is taken as input. If A is\n*        replaced with A^t, then the row pivoting is included automatically.\n*       = 'N': do not speculate.\n*        This option can be used to compute only the singular values, or the\n*        full SVD (U, SIGMA and V). For only one set of singular vectors\n*        (U or V), the caller should provide both U and V, as one of the\n*        matrices is used as workspace if the matrix A is transposed.\n*        The implementer can easily remove this constraint and make the\n*        code more complicated. See the descriptions of U and V.\n*\n*  JOBP    (input) CHARACTER*1\n*        Issues the licence to introduce structured perturbations to drown\n*        denormalized numbers. This licence should be active if the\n*        denormals are poorly implemented, causing slow computation,\n*        especially in cases of fast convergence (!). For details see [1,2].\n*        For the sake of simplicity, this perturbations are included only\n*        when the full SVD or only the singular values are requested. The\n*        implementer/user can easily add the perturbation for the cases of\n*        computing one set of singular vectors.\n*       = 'P': introduce perturbation\n*       = 'N': do not perturb\n*\n*  M       (input) INTEGER\n*         The number of rows of the input matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*         The number of columns of the input matrix A. M >= N >= 0.\n*\n*  A       (input/workspace) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  SVA     (workspace/output) DOUBLE PRECISION array, dimension (N)\n*          On exit,\n*          - For WORK(1)/WORK(2) = ONE: The singular values of A. During the\n*            computation SVA contains Euclidean column norms of the\n*            iterated matrices in the array A.\n*          - For WORK(1) .NE. WORK(2): The singular values of A are\n*            (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if\n*            sigma_max(A) overflows or if small singular values have been\n*            saved from underflow by scaling the input matrix A.\n*          - If JOBR='R' then some of the singular values may be returned\n*            as exact zeros obtained by \"set to zero\" because they are\n*            below the numerical rank threshold or are denormalized numbers.\n*\n*  U       (workspace/output) DOUBLE PRECISION array, dimension ( LDU, N )\n*          If JOBU = 'U', then U contains on exit the M-by-N matrix of\n*                         the left singular vectors.\n*          If JOBU = 'F', then U contains on exit the M-by-M matrix of\n*                         the left singular vectors, including an ONB\n*                         of the orthogonal complement of the Range(A).\n*          If JOBU = 'W'  .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N),\n*                         then U is used as workspace if the procedure\n*                         replaces A with A^t. In that case, [V] is computed\n*                         in U as left singular vectors of A^t and then\n*                         copied back to the V array. This 'W' option is just\n*                         a reminder to the caller that in this case U is\n*                         reserved as workspace of length N*N.\n*          If JOBU = 'N'  U is not referenced.\n*\n* LDU      (input) INTEGER\n*          The leading dimension of the array U,  LDU >= 1.\n*          IF  JOBU = 'U' or 'F' or 'W',  then LDU >= M.\n*\n*  V       (workspace/output) DOUBLE PRECISION array, dimension ( LDV, N )\n*          If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of\n*                         the right singular vectors;\n*          If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N),\n*                         then V is used as workspace if the pprocedure\n*                         replaces A with A^t. In that case, [U] is computed\n*                         in V as right singular vectors of A^t and then\n*                         copied back to the U array. This 'W' option is just\n*                         a reminder to the caller that in this case V is\n*                         reserved as workspace of length N*N.\n*          If JOBV = 'N'  V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V,  LDV >= 1.\n*          If JOBV = 'V' or 'J' or 'W', then LDV >= N.\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension at least LWORK.\n*          On exit,\n*          WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such\n*                    that SCALE*SVA(1:N) are the computed singular values\n*                    of A. (See the description of SVA().)\n*          WORK(2) = See the description of WORK(1).\n*          WORK(3) = SCONDA is an estimate for the condition number of\n*                    column equilibrated A. (If JOBA .EQ. 'E' or 'G')\n*                    SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1).\n*                    It is computed using DPOCON. It holds\n*                    N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA\n*                    where R is the triangular factor from the QRF of A.\n*                    However, if R is truncated and the numerical rank is\n*                    determined to be strictly smaller than N, SCONDA is\n*                    returned as -1, thus indicating that the smallest\n*                    singular values might be lost.\n*\n*          If full SVD is needed, the following two condition numbers are\n*          useful for the analysis of the algorithm. They are provied for\n*          a developer/implementer who is familiar with the details of\n*          the method.\n*\n*          WORK(4) = an estimate of the scaled condition number of the\n*                    triangular factor in the first QR factorization.\n*          WORK(5) = an estimate of the scaled condition number of the\n*                    triangular factor in the second QR factorization.\n*          The following two parameters are computed if JOBT .EQ. 'T'.\n*          They are provided for a developer/implementer who is familiar\n*          with the details of the method.\n*\n*          WORK(6) = the entropy of A^t*A :: this is the Shannon entropy\n*                    of diag(A^t*A) / Trace(A^t*A) taken as point in the\n*                    probability simplex.\n*          WORK(7) = the entropy of A*A^t.\n*\n*  LWORK   (input) INTEGER\n*          Length of WORK to confirm proper allocation of work space.\n*          LWORK depends on the job:\n*\n*          If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and\n*            -> .. no scaled condition estimate required ( JOBE.EQ.'N'):\n*               LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement.\n*               For optimal performance (blocked code) the optimal value\n*               is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal\n*               block size for xGEQP3/xGEQRF.\n*            -> .. an estimate of the scaled condition number of A is\n*               required (JOBA='E', 'G'). In this case, LWORK is the maximum\n*               of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7).\n*\n*          If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'),\n*            -> the minimal requirement is LWORK >= max(2*N+M,7).\n*            -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),\n*               where NB is the optimal block size.\n*\n*          If SIGMA and the left singular vectors are needed\n*            -> the minimal requirement is LWORK >= max(2*N+M,7).\n*            -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),\n*               where NB is the optimal block size.\n*\n*          If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and\n*            -> .. the singular vectors are computed without explicit\n*               accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N\n*            -> .. in the iterative part, the Jacobi rotations are\n*               explicitly accumulated (option, see the description of JOBV),\n*               then the minimal requirement is LWORK >= max(M+3*N+N*N,7).\n*               For better performance, if NB is the optimal block size,\n*               LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7).\n*\n*  IWORK   (workspace/output) INTEGER array, dimension M+3*N.\n*          On exit,\n*          IWORK(1) = the numerical rank determined after the initial\n*                     QR factorization with pivoting. See the descriptions\n*                     of JOBA and JOBR.\n*          IWORK(2) = the number of the computed nonzero singular values\n*          IWORK(3) = if nonzero, a warning message:\n*                     If IWORK(3).EQ.1 then some of the column norms of A\n*                     were denormalized floats. The requested high accuracy\n*                     is not warranted by the data.\n*\n*  INFO    (output) INTEGER\n*           < 0  : if INFO = -i, then the i-th argument had an illegal value.\n*           = 0 :  successfull exit;\n*           > 0 :  DGEJSV  did not converge in the maximal allowed number\n*                  of sweeps. The computed values may be inaccurate.\n*\n\n*  Further Details\n*  ===============\n*\n*  DGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3,\n*  SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an\n*  additional row pivoting can be used as a preprocessor, which in some\n*  cases results in much higher accuracy. An example is matrix A with the\n*  structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned\n*  diagonal matrices and C is well-conditioned matrix. In that case, complete\n*  pivoting in the first QR factorizations provides accuracy dependent on the\n*  condition number of C, and independent of D1, D2. Such higher accuracy is\n*  not completely understood theoretically, but it works well in practice.\n*  Further, if A can be written as A = B*D, with well-conditioned B and some\n*  diagonal D, then the high accuracy is guaranteed, both theoretically and\n*  in software, independent of D. For more details see [1], [2].\n*     The computational range for the singular values can be the full range\n*  ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS\n*  & LAPACK routines called by DGEJSV are implemented to work in that range.\n*  If that is not the case, then the restriction for safe computation with\n*  the singular values in the range of normalized IEEE numbers is that the\n*  spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not\n*  overflow. This code (DGEJSV) is best used in this restricted range,\n*  meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are\n*  returned as zeros. See JOBR for details on this.\n*     Further, this implementation is somewhat slower than the one described\n*  in [1,2] due to replacement of some non-LAPACK components, and because\n*  the choice of some tuning parameters in the iterative part (DGESVJ) is\n*  left to the implementer on a particular machine.\n*     The rank revealing QR factorization (in this code: SGEQP3) should be\n*  implemented as in [3]. We have a new version of SGEQP3 under development\n*  that is more robust than the current one in LAPACK, with a cleaner cut in\n*  rank defficient cases. It will be available in the SIGMA library [4].\n*  If M is much larger than N, it is obvious that the inital QRF with\n*  column pivoting can be preprocessed by the QRF without pivoting. That\n*  well known trick is not used in DGEJSV because in some cases heavy row\n*  weighting can be treated with complete pivoting. The overhead in cases\n*  M much larger than N is then only due to pivoting, but the benefits in\n*  terms of accuracy have prevailed. The implementer/user can incorporate\n*  this extra QRF step easily. The implementer can also improve data movement\n*  (matrix transpose, matrix copy, matrix transposed copy) - this\n*  implementation of DGEJSV uses only the simplest, naive data movement.\n*\n*  Contributors\n*\n*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n*  References\n*\n* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.\n*     SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.\n*     LAPACK Working note 169.\n* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.\n*     SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.\n*     LAPACK Working note 170.\n* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR\n*     factorization software - a case study.\n*     ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28.\n*     LAPACK Working note 176.\n* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,\n*     QSVD, (H,K)-SVD computations.\n*     Department of Mathematics, University of Zagreb, 2008.\n*\n*  Bugs, examples and comments\n* \n*  Please report all bugs and send interesting examples and/or comments to\n*  drmac@math.hr. Thank you.\n*\n* ==========================================================================\n*\n*     .. Local Parameters ..\n      DOUBLE PRECISION   ZERO,  ONE\n      PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )\n*     ..\n*     .. Local Scalars ..\n      DOUBLE PRECISION AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK,\n     &        CONDR1, CONDR2, ENTRA,  ENTRAT, EPSLN,  MAXPRJ, SCALEM,\n     &        SCONDA, SFMIN,  SMALL,  TEMP1,  USCAL1, USCAL2, XSC\n      INTEGER IERR,   N1,     NR,     NUMRANK,        p, q,   WARNING\n      LOGICAL ALMORT, DEFR,   ERREST, GOSCAL, JRACC,  KILL,   LSVEC,\n     &        L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN,\n     &        NOSCAL, ROWPIV, RSVEC,  TRANSP\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC DABS,  DLOG, DMAX1, DMIN1, DBLE,\n     &          MAX0, MIN0, IDNINT,  DSIGN,  DSQRT\n*     ..\n*     .. External Functions ..\n      DOUBLE PRECISION  DLAMCH, DNRM2\n      INTEGER   IDAMAX\n      LOGICAL   LSAME\n      EXTERNAL  IDAMAX, LSAME, DLAMCH, DNRM2\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL  DCOPY,  DGELQF, DGEQP3, DGEQRF, DLACPY, DLASCL,\n     &          DLASET, DLASSQ, DLASWP, DORGQR, DORMLQ,\n     &          DORMQR, DPOCON, DSCAL,  DSWAP,  DTRSM,  XERBLA\n*\n      EXTERNAL  DGESVJ\n*     ..\n*\n*     Test the input arguments\n*\n      LSVEC  = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' )\n      JRACC  = LSAME( JOBV, 'J' )\n      RSVEC  = LSAME( JOBV, 'V' ) .OR. JRACC\n      ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' )\n      L2RANK = LSAME( JOBA, 'R' )\n      L2ABER = LSAME( JOBA, 'A' )\n      ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' )\n      L2TRAN = LSAME( JOBT, 'T' )\n      L2KILL = LSAME( JOBR, 'R' )\n      DEFR   = LSAME( JOBR, 'N' )\n      L2PERT = LSAME( JOBP, 'P' )\n*\n      IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR.\n     &     ERREST .OR. LSAME( JOBA, 'C' ) )) THEN\n         INFO = - 1\n      ELSE IF ( .NOT.( LSVEC  .OR. LSAME( JOBU, 'N' ) .OR.\n     &                             LSAME( JOBU, 'W' )) ) THEN\n         INFO = - 2\n      ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR.\n     &   LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN\n         INFO = - 3\n      ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) )    THEN\n         INFO = - 4\n      ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN\n         INFO = - 5\n      ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN\n         INFO = - 6\n      ELSE IF ( M .LT. 0 ) THEN\n         INFO = - 7\n      ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN\n         INFO = - 8\n      ELSE IF ( LDA .LT. M ) THEN\n         INFO = - 10\n      ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN\n         INFO = - 13\n      ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN\n         INFO = - 14\n      ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND.\n     &                           (LWORK .LT. MAX0(7,4*N+1,2*M+N))) .OR.\n     & (.NOT.(LSVEC .OR. LSVEC) .AND. ERREST .AND.\n     &                         (LWORK .LT. MAX0(7,4*N+N*N,2*M+N))) .OR.\n     & (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.\n     & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.\n     & (LSVEC .AND. RSVEC .AND. .NOT.JRACC .AND. (LWORK.LT.6*N+2*N*N))\n     & .OR. (LSVEC.AND.RSVEC.AND.JRACC.AND.LWORK.LT.MAX0(7,M+3*N+N*N)))\n     &   THEN\n         INFO = - 17\n      ELSE\n*        #:)\n         INFO = 0\n      END IF\n*\n      IF ( INFO .NE. 0 ) THEN\n*       #:(\n         CALL XERBLA( 'DGEJSV', - INFO )\n      END IF\n*\n*     Quick return for void matrix (Y3K safe)\n* #:)\n      IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN\n*\n*     Determine whether the matrix U should be M x N or M x M\n*\n      IF ( LSVEC ) THEN\n         N1 = N\n         IF ( LSAME( JOBU, 'F' ) ) N1 = M\n      END IF\n*\n*     Set numerical parameters\n*\n*!    NOTE: Make sure DLAMCH() does not fail on the target architecture.\n*\n\n      EPSLN = DLAMCH('Epsilon')\n      SFMIN = DLAMCH('SafeMinimum')\n      SMALL = SFMIN / EPSLN\n      BIG   = DLAMCH('O')\n*     BIG   = ONE / SFMIN\n*\n*     Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N\n*\n*(!)  If necessary, scale SVA() to protect the largest norm from\n*     overflow. It is possible that this scaling pushes the smallest\n*     column norm left from the underflow threshold (extreme case).\n*\n      SCALEM  = ONE / DSQRT(DBLE(M)*DBLE(N))\n      NOSCAL  = .TRUE.\n      GOSCAL  = .TRUE.\n      DO 1874 p = 1, N\n         AAPP = ZERO\n         AAQQ = ONE\n         CALL DLASSQ( M, A(1,p), 1, AAPP, AAQQ )\n         IF ( AAPP .GT. BIG ) THEN\n            INFO = - 9\n            CALL XERBLA( 'DGEJSV', -INFO )\n            RETURN\n         END IF\n         AAQQ = DSQRT(AAQQ)\n         IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL  ) THEN\n            SVA(p)  = AAPP * AAQQ\n         ELSE\n            NOSCAL  = .FALSE.\n            SVA(p)  = AAPP * ( AAQQ * SCALEM )\n            IF ( GOSCAL ) THEN\n               GOSCAL = .FALSE.\n               CALL DSCAL( p-1, SCALEM, SVA, 1 )\n            END IF\n         END IF\n 1874 CONTINUE\n*\n      IF ( NOSCAL ) SCALEM = ONE\n*\n      AAPP = ZERO\n      AAQQ = BIG\n      DO 4781 p = 1, N\n         AAPP = DMAX1( AAPP, SVA(p) )\n         IF ( SVA(p) .NE. ZERO ) AAQQ = DMIN1( AAQQ, SVA(p) )\n 4781 CONTINUE\n*\n*     Quick return for zero M x N matrix\n* #:)\n      IF ( AAPP .EQ. ZERO ) THEN\n         IF ( LSVEC ) CALL DLASET( 'G', M, N1, ZERO, ONE, U, LDU )\n         IF ( RSVEC ) CALL DLASET( 'G', N, N,  ZERO, ONE, V, LDV )\n         WORK(1) = ONE\n         WORK(2) = ONE\n         IF ( ERREST ) WORK(3) = ONE\n         IF ( LSVEC .AND. RSVEC ) THEN\n            WORK(4) = ONE\n            WORK(5) = ONE\n         END IF\n         IF ( L2TRAN ) THEN\n            WORK(6) = ZERO\n            WORK(7) = ZERO\n         END IF\n         IWORK(1) = 0\n         IWORK(2) = 0\n         RETURN\n      END IF\n*\n*     Issue warning if denormalized column norms detected. Override the\n*     high relative accuracy request. Issue licence to kill columns\n*     (set them to zero) whose norm is less than sigma_max / BIG (roughly).\n* #:(\n      WARNING = 0\n      IF ( AAQQ .LE. SFMIN ) THEN\n         L2RANK = .TRUE.\n         L2KILL = .TRUE.\n         WARNING = 1\n      END IF\n*\n*     Quick return for one-column matrix\n* #:)\n      IF ( N .EQ. 1 ) THEN\n*\n         IF ( LSVEC ) THEN\n            CALL DLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR )\n            CALL DLACPY( 'A', M, 1, A, LDA, U, LDU )\n*           computing all M left singular vectors of the M x 1 matrix\n            IF ( N1 .NE. N  ) THEN\n               CALL DGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR )\n               CALL DORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR )\n               CALL DCOPY( M, A(1,1), 1, U(1,1), 1 )\n            END IF\n         END IF\n         IF ( RSVEC ) THEN\n             V(1,1) = ONE\n         END IF\n         IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN\n            SVA(1)  = SVA(1) / SCALEM\n            SCALEM  = ONE\n         END IF\n         WORK(1) = ONE / SCALEM\n         WORK(2) = ONE\n         IF ( SVA(1) .NE. ZERO ) THEN\n            IWORK(1) = 1\n            IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN\n               IWORK(2) = 1\n            ELSE\n               IWORK(2) = 0\n            END IF\n         ELSE\n            IWORK(1) = 0\n            IWORK(2) = 0\n         END IF\n         IF ( ERREST ) WORK(3) = ONE\n         IF ( LSVEC .AND. RSVEC ) THEN\n            WORK(4) = ONE\n            WORK(5) = ONE\n         END IF\n         IF ( L2TRAN ) THEN\n            WORK(6) = ZERO\n            WORK(7) = ZERO\n         END IF\n         RETURN\n*\n      END IF\n*\n      TRANSP = .FALSE.\n      L2TRAN = L2TRAN .AND. ( M .EQ. N )\n*\n      AATMAX = -ONE\n      AATMIN =  BIG\n      IF ( ROWPIV .OR. L2TRAN ) THEN\n*\n*     Compute the row norms, needed to determine row pivoting sequence\n*     (in the case of heavily row weighted A, row pivoting is strongly\n*     advised) and to collect information needed to compare the\n*     structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.).\n*\n         IF ( L2TRAN ) THEN\n            DO 1950 p = 1, M\n               XSC   = ZERO\n               TEMP1 = ONE\n               CALL DLASSQ( N, A(p,1), LDA, XSC, TEMP1 )\n*              DLASSQ gets both the ell_2 and the ell_infinity norm\n*              in one pass through the vector\n               WORK(M+N+p)  = XSC * SCALEM\n               WORK(N+p)    = XSC * (SCALEM*DSQRT(TEMP1))\n               AATMAX = DMAX1( AATMAX, WORK(N+p) )\n               IF (WORK(N+p) .NE. ZERO) AATMIN = DMIN1(AATMIN,WORK(N+p))\n 1950       CONTINUE\n         ELSE\n            DO 1904 p = 1, M\n               WORK(M+N+p) = SCALEM*DABS( A(p,IDAMAX(N,A(p,1),LDA)) )\n               AATMAX = DMAX1( AATMAX, WORK(M+N+p) )\n               AATMIN = DMIN1( AATMIN, WORK(M+N+p) )\n 1904       CONTINUE\n         END IF\n*\n      END IF\n*\n*     For square matrix A try to determine whether A^t  would be  better\n*     input for the preconditioned Jacobi SVD, with faster convergence.\n*     The decision is based on an O(N) function of the vector of column\n*     and row norms of A, based on the Shannon entropy. This should give\n*     the right choice in most cases when the difference actually matters.\n*     It may fail and pick the slower converging side.\n*\n      ENTRA  = ZERO\n      ENTRAT = ZERO\n      IF ( L2TRAN ) THEN\n*\n         XSC   = ZERO\n         TEMP1 = ONE\n         CALL DLASSQ( N, SVA, 1, XSC, TEMP1 )\n         TEMP1 = ONE / TEMP1\n*\n         ENTRA = ZERO\n         DO 1113 p = 1, N\n            BIG1  = ( ( SVA(p) / XSC )**2 ) * TEMP1\n            IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * DLOG(BIG1)\n 1113    CONTINUE\n         ENTRA = - ENTRA / DLOG(DBLE(N))\n*\n*        Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex.\n*        It is derived from the diagonal of  A^t * A.  Do the same with the\n*        diagonal of A * A^t, compute the entropy of the corresponding\n*        probability distribution. Note that A * A^t and A^t * A have the\n*        same trace.\n*\n         ENTRAT = ZERO\n         DO 1114 p = N+1, N+M\n            BIG1 = ( ( WORK(p) / XSC )**2 ) * TEMP1\n            IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * DLOG(BIG1)\n 1114    CONTINUE\n         ENTRAT = - ENTRAT / DLOG(DBLE(M))\n*\n*        Analyze the entropies and decide A or A^t. Smaller entropy\n*        usually means better input for the algorithm.\n*\n         TRANSP = ( ENTRAT .LT. ENTRA )\n*\n*        If A^t is better than A, transpose A.\n*\n         IF ( TRANSP ) THEN\n*           In an optimal implementation, this trivial transpose\n*           should be replaced with faster transpose.\n            DO 1115 p = 1, N - 1\n               DO 1116 q = p + 1, N\n                   TEMP1 = A(q,p)\n                  A(q,p) = A(p,q)\n                  A(p,q) = TEMP1\n 1116          CONTINUE\n 1115       CONTINUE\n            DO 1117 p = 1, N\n               WORK(M+N+p) = SVA(p)\n               SVA(p)      = WORK(N+p)\n 1117       CONTINUE\n            TEMP1  = AAPP\n            AAPP   = AATMAX\n            AATMAX = TEMP1\n            TEMP1  = AAQQ\n            AAQQ   = AATMIN\n            AATMIN = TEMP1\n            KILL   = LSVEC\n            LSVEC  = RSVEC\n            RSVEC  = KILL\n            IF ( LSVEC ) N1 = N\n*\n            ROWPIV = .TRUE.\n         END IF\n*\n      END IF\n*     END IF L2TRAN\n*\n*     Scale the matrix so that its maximal singular value remains less\n*     than DSQRT(BIG) -- the matrix is scaled so that its maximal column\n*     has Euclidean norm equal to DSQRT(BIG/N). The only reason to keep\n*     DSQRT(BIG) instead of BIG is the fact that DGEJSV uses LAPACK and\n*     BLAS routines that, in some implementations, are not capable of\n*     working in the full interval [SFMIN,BIG] and that they may provoke\n*     overflows in the intermediate results. If the singular values spread\n*     from SFMIN to BIG, then DGESVJ will compute them. So, in that case,\n*     one should use DGESVJ instead of DGEJSV.\n*\n      BIG1   = DSQRT( BIG )\n      TEMP1  = DSQRT( BIG / DBLE(N) )\n*\n      CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR )\n      IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN\n          AAQQ = ( AAQQ / AAPP ) * TEMP1\n      ELSE\n          AAQQ = ( AAQQ * TEMP1 ) / AAPP\n      END IF\n      TEMP1 = TEMP1 * SCALEM\n      CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR )\n*\n*     To undo scaling at the end of this procedure, multiply the\n*     computed singular values with USCAL2 / USCAL1.\n*\n      USCAL1 = TEMP1\n      USCAL2 = AAPP\n*\n      IF ( L2KILL ) THEN\n*        L2KILL enforces computation of nonzero singular values in\n*        the restricted range of condition number of the initial A,\n*        sigma_max(A) / sigma_min(A) approx. DSQRT(BIG)/DSQRT(SFMIN).\n         XSC = DSQRT( SFMIN )\n      ELSE\n         XSC = SMALL\n*\n*        Now, if the condition number of A is too big,\n*        sigma_max(A) / sigma_min(A) .GT. DSQRT(BIG/N) * EPSLN / SFMIN,\n*        as a precaution measure, the full SVD is computed using DGESVJ\n*        with accumulated Jacobi rotations. This provides numerically\n*        more robust computation, at the cost of slightly increased run\n*        time. Depending on the concrete implementation of BLAS and LAPACK\n*        (i.e. how they behave in presence of extreme ill-conditioning) the\n*        implementor may decide to remove this switch.\n         IF ( ( AAQQ.LT.DSQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN\n            JRACC = .TRUE.\n         END IF\n*\n      END IF\n      IF ( AAQQ .LT. XSC ) THEN\n         DO 700 p = 1, N\n            IF ( SVA(p) .LT. XSC ) THEN\n               CALL DLASET( 'A', M, 1, ZERO, ZERO, A(1,p), LDA )\n               SVA(p) = ZERO\n            END IF\n 700     CONTINUE\n      END IF\n*\n*     Preconditioning using QR factorization with pivoting\n*\n      IF ( ROWPIV ) THEN\n*        Optional row permutation (Bjoerck row pivoting):\n*        A result by Cox and Higham shows that the Bjoerck's\n*        row pivoting combined with standard column pivoting\n*        has similar effect as Powell-Reid complete pivoting.\n*        The ell-infinity norms of A are made nonincreasing.\n         DO 1952 p = 1, M - 1\n            q = IDAMAX( M-p+1, WORK(M+N+p), 1 ) + p - 1\n            IWORK(2*N+p) = q\n            IF ( p .NE. q ) THEN\n               TEMP1       = WORK(M+N+p)\n               WORK(M+N+p) = WORK(M+N+q)\n               WORK(M+N+q) = TEMP1\n            END IF\n 1952    CONTINUE\n         CALL DLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 )\n      END IF\n*\n*     End of the preparation phase (scaling, optional sorting and\n*     transposing, optional flushing of small columns).\n*\n*     Preconditioning\n*\n*     If the full SVD is needed, the right singular vectors are computed\n*     from a matrix equation, and for that we need theoretical analysis\n*     of the Businger-Golub pivoting. So we use DGEQP3 as the first RR QRF.\n*     In all other cases the first RR QRF can be chosen by other criteria\n*     (eg speed by replacing global with restricted window pivoting, such\n*     as in SGEQPX from TOMS # 782). Good results will be obtained using\n*     SGEQPX with properly (!) chosen numerical parameters.\n*     Any improvement of DGEQP3 improves overal performance of DGEJSV.\n*\n*     A * P1 = Q1 * [ R1^t 0]^t:\n      DO 1963 p = 1, N\n*        .. all columns are free columns\n         IWORK(p) = 0\n 1963 CONTINUE\n      CALL DGEQP3( M,N,A,LDA, IWORK,WORK, WORK(N+1),LWORK-N, IERR )\n*\n*     The upper triangular matrix R1 from the first QRF is inspected for\n*     rank deficiency and possibilities for deflation, or possible\n*     ill-conditioning. Depending on the user specified flag L2RANK,\n*     the procedure explores possibilities to reduce the numerical\n*     rank by inspecting the computed upper triangular factor. If\n*     L2RANK or L2ABER are up, then DGEJSV will compute the SVD of\n*     A + dA, where ||dA|| <= f(M,N)*EPSLN.\n*\n      NR = 1\n      IF ( L2ABER ) THEN\n*        Standard absolute error bound suffices. All sigma_i with\n*        sigma_i < N*EPSLN*||A|| are flushed to zero. This is an\n*        agressive enforcement of lower numerical rank by introducing a\n*        backward error of the order of N*EPSLN*||A||.\n         TEMP1 = DSQRT(DBLE(N))*EPSLN\n         DO 3001 p = 2, N\n            IF ( DABS(A(p,p)) .GE. (TEMP1*DABS(A(1,1))) ) THEN\n               NR = NR + 1\n            ELSE\n               GO TO 3002\n            END IF\n 3001    CONTINUE\n 3002    CONTINUE\n      ELSE IF ( L2RANK ) THEN\n*        .. similarly as above, only slightly more gentle (less agressive).\n*        Sudden drop on the diagonal of R1 is used as the criterion for\n*        close-to-rank-defficient.\n         TEMP1 = DSQRT(SFMIN)\n         DO 3401 p = 2, N\n            IF ( ( DABS(A(p,p)) .LT. (EPSLN*DABS(A(p-1,p-1))) ) .OR.\n     &           ( DABS(A(p,p)) .LT. SMALL ) .OR.\n     &           ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402\n            NR = NR + 1\n 3401    CONTINUE\n 3402    CONTINUE\n*\n      ELSE\n*        The goal is high relative accuracy. However, if the matrix\n*        has high scaled condition number the relative accuracy is in\n*        general not feasible. Later on, a condition number estimator\n*        will be deployed to estimate the scaled condition number.\n*        Here we just remove the underflowed part of the triangular\n*        factor. This prevents the situation in which the code is\n*        working hard to get the accuracy not warranted by the data.\n         TEMP1  = DSQRT(SFMIN)\n         DO 3301 p = 2, N\n            IF ( ( DABS(A(p,p)) .LT. SMALL ) .OR.\n     &          ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302\n            NR = NR + 1\n 3301    CONTINUE\n 3302    CONTINUE\n*\n      END IF\n*\n      ALMORT = .FALSE.\n      IF ( NR .EQ. N ) THEN\n         MAXPRJ = ONE\n         DO 3051 p = 2, N\n            TEMP1  = DABS(A(p,p)) / SVA(IWORK(p))\n            MAXPRJ = DMIN1( MAXPRJ, TEMP1 )\n 3051    CONTINUE\n         IF ( MAXPRJ**2 .GE. ONE - DBLE(N)*EPSLN ) ALMORT = .TRUE.\n      END IF\n*\n*\n      SCONDA = - ONE\n      CONDR1 = - ONE\n      CONDR2 = - ONE\n*\n      IF ( ERREST ) THEN\n         IF ( N .EQ. NR ) THEN\n            IF ( RSVEC ) THEN\n*              .. V is available as workspace\n               CALL DLACPY( 'U', N, N, A, LDA, V, LDV )\n               DO 3053 p = 1, N\n                  TEMP1 = SVA(IWORK(p))\n                  CALL DSCAL( p, ONE/TEMP1, V(1,p), 1 )\n 3053          CONTINUE\n               CALL DPOCON( 'U', N, V, LDV, ONE, TEMP1,\n     &              WORK(N+1), IWORK(2*N+M+1), IERR )\n            ELSE IF ( LSVEC ) THEN\n*              .. U is available as workspace\n               CALL DLACPY( 'U', N, N, A, LDA, U, LDU )\n               DO 3054 p = 1, N\n                  TEMP1 = SVA(IWORK(p))\n                  CALL DSCAL( p, ONE/TEMP1, U(1,p), 1 )\n 3054          CONTINUE\n               CALL DPOCON( 'U', N, U, LDU, ONE, TEMP1,\n     &              WORK(N+1), IWORK(2*N+M+1), IERR )\n            ELSE\n               CALL DLACPY( 'U', N, N, A, LDA, WORK(N+1), N )\n               DO 3052 p = 1, N\n                  TEMP1 = SVA(IWORK(p))\n                  CALL DSCAL( p, ONE/TEMP1, WORK(N+(p-1)*N+1), 1 )\n 3052          CONTINUE\n*           .. the columns of R are scaled to have unit Euclidean lengths.\n               CALL DPOCON( 'U', N, WORK(N+1), N, ONE, TEMP1,\n     &              WORK(N+N*N+1), IWORK(2*N+M+1), IERR )\n            END IF\n            SCONDA = ONE / DSQRT(TEMP1)\n*           SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1).\n*           N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA\n         ELSE\n            SCONDA = - ONE\n         END IF\n      END IF\n*\n      L2PERT = L2PERT .AND. ( DABS( A(1,1)/A(NR,NR) ) .GT. DSQRT(BIG1) )\n*     If there is no violent scaling, artificial perturbation is not needed.\n*\n*     Phase 3:\n*\n\n      IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN\n*\n*         Singular Values only\n*\n*         .. transpose A(1:NR,1:N)\n         DO 1946 p = 1, MIN0( N-1, NR )\n            CALL DCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 )\n 1946    CONTINUE\n*\n*        The following two DO-loops introduce small relative perturbation\n*        into the strict upper triangle of the lower triangular matrix.\n*        Small entries below the main diagonal are also changed.\n*        This modification is useful if the computing environment does not\n*        provide/allow FLUSH TO ZERO underflow, for it prevents many\n*        annoying denormalized numbers in case of strongly scaled matrices.\n*        The perturbation is structured so that it does not introduce any\n*        new perturbation of the singular values, and it does not destroy\n*        the job done by the preconditioner.\n*        The licence for this perturbation is in the variable L2PERT, which\n*        should be .FALSE. if FLUSH TO ZERO underflow is active.\n*\n         IF ( .NOT. ALMORT ) THEN\n*\n            IF ( L2PERT ) THEN\n*              XSC = DSQRT(SMALL)\n               XSC = EPSLN / DBLE(N)\n               DO 4947 q = 1, NR\n                  TEMP1 = XSC*DABS(A(q,q))\n                  DO 4949 p = 1, N\n                     IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) )\n     &                    .OR. ( p .LT. q ) )\n     &                     A(p,q) = DSIGN( TEMP1, A(p,q) )\n 4949             CONTINUE\n 4947          CONTINUE\n            ELSE\n               CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, A(1,2),LDA )\n            END IF\n*\n*            .. second preconditioning using the QR factorization\n*\n            CALL DGEQRF( N,NR, A,LDA, WORK, WORK(N+1),LWORK-N, IERR )\n*\n*           .. and transpose upper to lower triangular\n            DO 1948 p = 1, NR - 1\n               CALL DCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 )\n 1948       CONTINUE\n*\n         END IF\n*\n*           Row-cyclic Jacobi SVD algorithm with column pivoting\n*\n*           .. again some perturbation (a \"background noise\") is added\n*           to drown denormals\n            IF ( L2PERT ) THEN\n*              XSC = DSQRT(SMALL)\n               XSC = EPSLN / DBLE(N)\n               DO 1947 q = 1, NR\n                  TEMP1 = XSC*DABS(A(q,q))\n                  DO 1949 p = 1, NR\n                     IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) )\n     &                       .OR. ( p .LT. q ) )\n     &                   A(p,q) = DSIGN( TEMP1, A(p,q) )\n 1949             CONTINUE\n 1947          CONTINUE\n            ELSE\n               CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, A(1,2), LDA )\n            END IF\n*\n*           .. and one-sided Jacobi rotations are started on a lower\n*           triangular matrix (plus perturbation which is ignored in\n*           the part which destroys triangular form (confusing?!))\n*\n            CALL DGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA,\n     &                      N, V, LDV, WORK, LWORK, INFO )\n*\n            SCALEM  = WORK(1)\n            NUMRANK = IDNINT(WORK(2))\n*\n*\n      ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN\n*\n*        -> Singular Values and Right Singular Vectors <-\n*\n         IF ( ALMORT ) THEN\n*\n*           .. in this case NR equals N\n            DO 1998 p = 1, NR\n               CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1998       CONTINUE\n            CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n            CALL DGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA,\n     &                  WORK, LWORK, INFO )\n            SCALEM  = WORK(1)\n            NUMRANK = IDNINT(WORK(2))\n\n         ELSE\n*\n*        .. two more QR factorizations ( one QRF is not enough, two require\n*        accumulated product of Jacobi rotations, three are perfect )\n*\n            CALL DLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA )\n            CALL DGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR)\n            CALL DLACPY( 'Lower', NR, NR, A, LDA, V, LDV )\n            CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n            CALL DGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n     &                   LWORK-2*N, IERR )\n            DO 8998 p = 1, NR\n               CALL DCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 )\n 8998       CONTINUE\n            CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n            CALL DGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U,\n     &                  LDU, WORK(N+1), LWORK, INFO )\n            SCALEM  = WORK(N+1)\n            NUMRANK = IDNINT(WORK(N+2))\n            IF ( NR .LT. N ) THEN\n               CALL DLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1),   LDV )\n               CALL DLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1),   LDV )\n               CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV )\n            END IF\n*\n         CALL DORMLQ( 'Left', 'Transpose', N, N, NR, A, LDA, WORK,\n     &               V, LDV, WORK(N+1), LWORK-N, IERR )\n*\n         END IF\n*\n         DO 8991 p = 1, N\n            CALL DCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA )\n 8991    CONTINUE\n         CALL DLACPY( 'All', N, N, A, LDA, V, LDV )\n*\n         IF ( TRANSP ) THEN\n            CALL DLACPY( 'All', N, N, V, LDV, U, LDU )\n         END IF\n*\n      ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN\n*\n*        .. Singular Values and Left Singular Vectors                 ..\n*\n*        .. second preconditioning step to avoid need to accumulate\n*        Jacobi rotations in the Jacobi iterations.\n         DO 1965 p = 1, NR\n            CALL DCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 )\n 1965    CONTINUE\n         CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n         CALL DGEQRF( N, NR, U, LDU, WORK(N+1), WORK(2*N+1),\n     &              LWORK-2*N, IERR )\n*\n         DO 1967 p = 1, NR - 1\n            CALL DCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 )\n 1967    CONTINUE\n         CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n         CALL DGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A,\n     &        LDA, WORK(N+1), LWORK-N, INFO )\n         SCALEM  = WORK(N+1)\n         NUMRANK = IDNINT(WORK(N+2))\n*\n         IF ( NR .LT. M ) THEN\n            CALL DLASET( 'A',  M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU )\n            IF ( NR .LT. N1 ) THEN\n               CALL DLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU )\n               CALL DLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU )\n            END IF\n         END IF\n*\n         CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n     &               LDU, WORK(N+1), LWORK-N, IERR )\n*\n         IF ( ROWPIV )\n     &       CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n         DO 1974 p = 1, N1\n            XSC = ONE / DNRM2( M, U(1,p), 1 )\n            CALL DSCAL( M, XSC, U(1,p), 1 )\n 1974    CONTINUE\n*\n         IF ( TRANSP ) THEN\n            CALL DLACPY( 'All', N, N, U, LDU, V, LDV )\n         END IF\n*\n      ELSE\n*\n*        .. Full SVD ..\n*\n         IF ( .NOT. JRACC ) THEN\n*\n         IF ( .NOT. ALMORT ) THEN\n*\n*           Second Preconditioning Step (QRF [with pivoting])\n*           Note that the composition of TRANSPOSE, QRF and TRANSPOSE is\n*           equivalent to an LQF CALL. Since in many libraries the QRF\n*           seems to be better optimized than the LQF, we do explicit\n*           transpose and use the QRF. This is subject to changes in an\n*           optimized implementation of DGEJSV.\n*\n            DO 1968 p = 1, NR\n               CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1968       CONTINUE\n*\n*           .. the following two loops perturb small entries to avoid\n*           denormals in the second QR factorization, where they are\n*           as good as zeros. This is done to avoid painfully slow\n*           computation with denormals. The relative size of the perturbation\n*           is a parameter that can be changed by the implementer.\n*           This perturbation device will be obsolete on machines with\n*           properly implemented arithmetic.\n*           To switch it off, set L2PERT=.FALSE. To remove it from  the\n*           code, remove the action under L2PERT=.TRUE., leave the ELSE part.\n*           The following two loops should be blocked and fused with the\n*           transposed copy above.\n*\n            IF ( L2PERT ) THEN\n               XSC = DSQRT(SMALL)\n               DO 2969 q = 1, NR\n                  TEMP1 = XSC*DABS( V(q,q) )\n                  DO 2968 p = 1, N\n                     IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 )\n     &                   .OR. ( p .LT. q ) )\n     &                   V(p,q) = DSIGN( TEMP1, V(p,q) )\n                     IF ( p. LT. q ) V(p,q) = - V(p,q)\n 2968             CONTINUE\n 2969          CONTINUE\n            ELSE\n               CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n            END IF\n*\n*           Estimate the row scaled condition number of R1\n*           (If R1 is rectangular, N > NR, then the condition number\n*           of the leading NR x NR submatrix is estimated.)\n*\n            CALL DLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR )\n            DO 3950 p = 1, NR\n               TEMP1 = DNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1)\n               CALL DSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1)\n 3950       CONTINUE\n            CALL DPOCON('Lower',NR,WORK(2*N+1),NR,ONE,TEMP1,\n     &                   WORK(2*N+NR*NR+1),IWORK(M+2*N+1),IERR)\n            CONDR1 = ONE / DSQRT(TEMP1)\n*           .. here need a second oppinion on the condition number\n*           .. then assume worst case scenario\n*           R1 is OK for inverse <=> CONDR1 .LT. DBLE(N)\n*           more conservative    <=> CONDR1 .LT. DSQRT(DBLE(N))\n*\n            COND_OK = DSQRT(DBLE(NR))\n*[TP]       COND_OK is a tuning parameter.\n\n            IF ( CONDR1 .LT. COND_OK ) THEN\n*              .. the second QRF without pivoting. Note: in an optimized\n*              implementation, this QRF should be implemented as the QRF\n*              of a lower triangular matrix.\n*              R1^t = Q2 * R2\n               CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n     &              LWORK-2*N, IERR )\n*\n               IF ( L2PERT ) THEN\n                  XSC = DSQRT(SMALL)/EPSLN\n                  DO 3959 p = 2, NR\n                     DO 3958 q = 1, p - 1\n                        TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))\n                        IF ( DABS(V(q,p)) .LE. TEMP1 )\n     &                     V(q,p) = DSIGN( TEMP1, V(q,p) )\n 3958                CONTINUE\n 3959             CONTINUE\n               END IF\n*\n               IF ( NR .NE. N )\n*              .. save ...\n     &         CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n*           .. this transposed copy should be better than naive\n               DO 1969 p = 1, NR - 1\n                  CALL DCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 )\n 1969          CONTINUE\n*\n               CONDR2 = CONDR1\n*\n            ELSE\n*\n*              .. ill-conditioned case: second QRF with pivoting\n*              Note that windowed pivoting would be equaly good\n*              numerically, and more run-time efficient. So, in\n*              an optimal implementation, the next call to DGEQP3\n*              should be replaced with eg. CALL SGEQPX (ACM TOMS #782)\n*              with properly (carefully) chosen parameters.\n*\n*              R1^t * P2 = Q2 * R2\n               DO 3003 p = 1, NR\n                  IWORK(N+p) = 0\n 3003          CONTINUE\n               CALL DGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1),\n     &                  WORK(2*N+1), LWORK-2*N, IERR )\n**               CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n**     &              LWORK-2*N, IERR )\n               IF ( L2PERT ) THEN\n                  XSC = DSQRT(SMALL)\n                  DO 3969 p = 2, NR\n                     DO 3968 q = 1, p - 1\n                        TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))\n                        IF ( DABS(V(q,p)) .LE. TEMP1 )\n     &                     V(q,p) = DSIGN( TEMP1, V(q,p) )\n 3968                CONTINUE\n 3969             CONTINUE\n               END IF\n*\n               CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n               IF ( L2PERT ) THEN\n                  XSC = DSQRT(SMALL)\n                  DO 8970 p = 2, NR\n                     DO 8971 q = 1, p - 1\n                        TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))\n                        V(p,q) = - DSIGN( TEMP1, V(q,p) )\n 8971                CONTINUE\n 8970             CONTINUE\n               ELSE\n                  CALL DLASET( 'L',NR-1,NR-1,ZERO,ZERO,V(2,1),LDV )\n               END IF\n*              Now, compute R2 = L3 * Q3, the LQ factorization.\n               CALL DGELQF( NR, NR, V, LDV, WORK(2*N+N*NR+1),\n     &               WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR )\n*              .. and estimate the condition number\n               CALL DLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR )\n               DO 4950 p = 1, NR\n                  TEMP1 = DNRM2( p, WORK(2*N+N*NR+NR+p), NR )\n                  CALL DSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR )\n 4950          CONTINUE\n               CALL DPOCON( 'L',NR,WORK(2*N+N*NR+NR+1),NR,ONE,TEMP1,\n     &              WORK(2*N+N*NR+NR+NR*NR+1),IWORK(M+2*N+1),IERR )\n               CONDR2 = ONE / DSQRT(TEMP1)\n*\n               IF ( CONDR2 .GE. COND_OK ) THEN\n*                 .. save the Householder vectors used for Q3\n*                 (this overwrittes the copy of R2, as it will not be\n*                 needed in this branch, but it does not overwritte the\n*                 Huseholder vectors of Q2.).\n                  CALL DLACPY( 'U', NR, NR, V, LDV, WORK(2*N+1), N )\n*                 .. and the rest of the information on Q3 is in\n*                 WORK(2*N+N*NR+1:2*N+N*NR+N)\n               END IF\n*\n            END IF\n*\n            IF ( L2PERT ) THEN\n               XSC = DSQRT(SMALL)\n               DO 4968 q = 2, NR\n                  TEMP1 = XSC * V(q,q)\n                  DO 4969 p = 1, q - 1\n*                    V(p,q) = - DSIGN( TEMP1, V(q,p) )\n                     V(p,q) = - DSIGN( TEMP1, V(p,q) )\n 4969             CONTINUE\n 4968          CONTINUE\n            ELSE\n               CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, V(1,2), LDV )\n            END IF\n*\n*        Second preconditioning finished; continue with Jacobi SVD\n*        The input matrix is lower trinagular.\n*\n*        Recover the right singular vectors as solution of a well\n*        conditioned triangular matrix equation.\n*\n            IF ( CONDR1 .LT. COND_OK ) THEN\n*\n               CALL DGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U,\n     &              LDU,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,INFO )\n               SCALEM  = WORK(2*N+N*NR+NR+1)\n               NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))\n               DO 3970 p = 1, NR\n                  CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 )\n                  CALL DSCAL( NR, SVA(p),    V(1,p), 1 )\n 3970          CONTINUE\n\n*        .. pick the right matrix equation and solve it\n*\n               IF ( NR. EQ. N ) THEN\n* :))             .. best case, R1 is inverted. The solution of this matrix\n*                 equation is Q2*V2 = the product of the Jacobi rotations\n*                 used in DGESVJ, premultiplied with the orthogonal matrix\n*                 from the second QR factorization.\n                  CALL DTRSM( 'L','U','N','N', NR,NR,ONE, A,LDA, V,LDV )\n               ELSE\n*                 .. R1 is well conditioned, but non-square. Transpose(R2)\n*                 is inverted to get the product of the Jacobi rotations\n*                 used in DGESVJ. The Q-factor from the second QR\n*                 factorization is then built in explicitly.\n                  CALL DTRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1),\n     &                 N,V,LDV)\n                  IF ( NR .LT. N ) THEN\n                    CALL DLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV)\n                    CALL DLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV)\n                    CALL DLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV)\n                  END IF\n                  CALL DORMQR('L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n     &                 V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR)\n               END IF\n*\n            ELSE IF ( CONDR2 .LT. COND_OK ) THEN\n*\n* :)           .. the input matrix A is very likely a relative of\n*              the Kahan matrix :)\n*              The matrix R2 is inverted. The solution of the matrix equation\n*              is Q3^T*V3 = the product of the Jacobi rotations (appplied to\n*              the lower triangular L3 from the LQ factorization of\n*              R2=L3*Q3), pre-multiplied with the transposed Q3.\n               CALL DGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U,\n     &              LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )\n               SCALEM  = WORK(2*N+N*NR+NR+1)\n               NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))\n               DO 3870 p = 1, NR\n                  CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 )\n                  CALL DSCAL( NR, SVA(p),    U(1,p), 1 )\n 3870          CONTINUE\n               CALL DTRSM('L','U','N','N',NR,NR,ONE,WORK(2*N+1),N,U,LDU)\n*              .. apply the permutation from the second QR factorization\n               DO 873 q = 1, NR\n                  DO 872 p = 1, NR\n                     WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)\n 872              CONTINUE\n                  DO 874 p = 1, NR\n                     U(p,q) = WORK(2*N+N*NR+NR+p)\n 874              CONTINUE\n 873           CONTINUE\n               IF ( NR .LT. N ) THEN\n                  CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n                  CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n                  CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n               END IF\n               CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n     &              V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n            ELSE\n*              Last line of defense.\n* #:(          This is a rather pathological case: no scaled condition\n*              improvement after two pivoted QR factorizations. Other\n*              possibility is that the rank revealing QR factorization\n*              or the condition estimator has failed, or the COND_OK\n*              is set very close to ONE (which is unnecessary). Normally,\n*              this branch should never be executed, but in rare cases of\n*              failure of the RRQR or condition estimator, the last line of\n*              defense ensures that DGEJSV completes the task.\n*              Compute the full SVD of L3 using DGESVJ with explicit\n*              accumulation of Jacobi rotations.\n               CALL DGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U,\n     &              LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )\n               SCALEM  = WORK(2*N+N*NR+NR+1)\n               NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))\n               IF ( NR .LT. N ) THEN\n                  CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n                  CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n                  CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n               END IF\n               CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n     &              V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n*\n               CALL DORMLQ( 'L', 'T', NR, NR, NR, WORK(2*N+1), N,\n     &              WORK(2*N+N*NR+1), U, LDU, WORK(2*N+N*NR+NR+1),\n     &              LWORK-2*N-N*NR-NR, IERR )\n               DO 773 q = 1, NR\n                  DO 772 p = 1, NR\n                     WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)\n 772              CONTINUE\n                  DO 774 p = 1, NR\n                     U(p,q) = WORK(2*N+N*NR+NR+p)\n 774              CONTINUE\n 773           CONTINUE\n*\n            END IF\n*\n*           Permute the rows of V using the (column) permutation from the\n*           first QRF. Also, scale the columns to make them unit in\n*           Euclidean norm. This applies to all cases.\n*\n            TEMP1 = DSQRT(DBLE(N)) * EPSLN\n            DO 1972 q = 1, N\n               DO 972 p = 1, N\n                  WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)\n  972          CONTINUE\n               DO 973 p = 1, N\n                  V(p,q) = WORK(2*N+N*NR+NR+p)\n  973          CONTINUE\n               XSC = ONE / DNRM2( N, V(1,q), 1 )\n               IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n     &           CALL DSCAL( N, XSC, V(1,q), 1 )\n 1972       CONTINUE\n*           At this moment, V contains the right singular vectors of A.\n*           Next, assemble the left singular vector matrix U (M x N).\n            IF ( NR .LT. M ) THEN\n               CALL DLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n               IF ( NR .LT. N1 ) THEN\n                  CALL DLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU)\n                  CALL DLASET('A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1),LDU)\n               END IF\n            END IF\n*\n*           The Q matrix from the first QRF is built into the left singular\n*           matrix U. This applies to all cases.\n*\n            CALL DORMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, WORK, U,\n     &           LDU, WORK(N+1), LWORK-N, IERR )\n\n*           The columns of U are normalized. The cost is O(M*N) flops.\n            TEMP1 = DSQRT(DBLE(M)) * EPSLN\n            DO 1973 p = 1, NR\n               XSC = ONE / DNRM2( M, U(1,p), 1 )\n               IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n     &          CALL DSCAL( M, XSC, U(1,p), 1 )\n 1973       CONTINUE\n*\n*           If the initial QRF is computed with row pivoting, the left\n*           singular vectors must be adjusted.\n*\n            IF ( ROWPIV )\n     &          CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n         ELSE\n*\n*        .. the initial matrix A has almost orthogonal columns and\n*        the second QRF is not needed\n*\n            CALL DLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N )\n            IF ( L2PERT ) THEN\n               XSC = DSQRT(SMALL)\n               DO 5970 p = 2, N\n                  TEMP1 = XSC * WORK( N + (p-1)*N + p )\n                  DO 5971 q = 1, p - 1\n                     WORK(N+(q-1)*N+p)=-DSIGN(TEMP1,WORK(N+(p-1)*N+q))\n 5971             CONTINUE\n 5970          CONTINUE\n            ELSE\n               CALL DLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N )\n            END IF\n*\n            CALL DGESVJ( 'Upper', 'U', 'N', N, N, WORK(N+1), N, SVA,\n     &           N, U, LDU, WORK(N+N*N+1), LWORK-N-N*N, INFO )\n*\n            SCALEM  = WORK(N+N*N+1)\n            NUMRANK = IDNINT(WORK(N+N*N+2))\n            DO 6970 p = 1, N\n               CALL DCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 )\n               CALL DSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 )\n 6970       CONTINUE\n*\n            CALL DTRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N,\n     &           ONE, A, LDA, WORK(N+1), N )\n            DO 6972 p = 1, N\n               CALL DCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV )\n 6972       CONTINUE\n            TEMP1 = DSQRT(DBLE(N))*EPSLN\n            DO 6971 p = 1, N\n               XSC = ONE / DNRM2( N, V(1,p), 1 )\n               IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n     &            CALL DSCAL( N, XSC, V(1,p), 1 )\n 6971       CONTINUE\n*\n*           Assemble the left singular vector matrix U (M x N).\n*\n            IF ( N .LT. M ) THEN\n               CALL DLASET( 'A',  M-N, N, ZERO, ZERO, U(N+1,1), LDU )\n               IF ( N .LT. N1 ) THEN\n                  CALL DLASET( 'A',N,  N1-N, ZERO, ZERO,  U(1,N+1),LDU )\n                  CALL DLASET( 'A',M-N,N1-N, ZERO, ONE,U(N+1,N+1),LDU )\n               END IF\n            END IF\n            CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n     &           LDU, WORK(N+1), LWORK-N, IERR )\n            TEMP1 = DSQRT(DBLE(M))*EPSLN\n            DO 6973 p = 1, N1\n               XSC = ONE / DNRM2( M, U(1,p), 1 )\n               IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n     &            CALL DSCAL( M, XSC, U(1,p), 1 )\n 6973       CONTINUE\n*\n            IF ( ROWPIV )\n     &         CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n         END IF\n*\n*        end of the  >> almost orthogonal case <<  in the full SVD\n*\n         ELSE\n*\n*        This branch deploys a preconditioned Jacobi SVD with explicitly\n*        accumulated rotations. It is included as optional, mainly for\n*        experimental purposes. It does perfom well, and can also be used.\n*        In this implementation, this branch will be automatically activated\n*        if the  condition number sigma_max(A) / sigma_min(A) is predicted\n*        to be greater than the overflow threshold. This is because the\n*        a posteriori computation of the singular vectors assumes robust\n*        implementation of BLAS and some LAPACK procedures, capable of working\n*        in presence of extreme values. Since that is not always the case, ...\n*\n         DO 7968 p = 1, NR\n            CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 7968    CONTINUE\n*\n         IF ( L2PERT ) THEN\n            XSC = DSQRT(SMALL/EPSLN)\n            DO 5969 q = 1, NR\n               TEMP1 = XSC*DABS( V(q,q) )\n               DO 5968 p = 1, N\n                  IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 )\n     &                .OR. ( p .LT. q ) )\n     &                V(p,q) = DSIGN( TEMP1, V(p,q) )\n                  IF ( p. LT. q ) V(p,q) = - V(p,q)\n 5968          CONTINUE\n 5969       CONTINUE\n         ELSE\n            CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n         END IF\n\n         CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n     &        LWORK-2*N, IERR )\n         CALL DLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N )\n*\n         DO 7969 p = 1, NR\n            CALL DCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 )\n 7969    CONTINUE\n\n         IF ( L2PERT ) THEN\n            XSC = DSQRT(SMALL/EPSLN)\n            DO 9970 q = 2, NR\n               DO 9971 p = 1, q - 1\n                  TEMP1 = XSC * DMIN1(DABS(U(p,p)),DABS(U(q,q)))\n                  U(p,q) = - DSIGN( TEMP1, U(q,p) )\n 9971          CONTINUE\n 9970       CONTINUE\n         ELSE\n            CALL DLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n         END IF\n\n         CALL DGESVJ( 'G', 'U', 'V', NR, NR, U, LDU, SVA,\n     &        N, V, LDV, WORK(2*N+N*NR+1), LWORK-2*N-N*NR, INFO )\n         SCALEM  = WORK(2*N+N*NR+1)\n         NUMRANK = IDNINT(WORK(2*N+N*NR+2))\n\n         IF ( NR .LT. N ) THEN\n            CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n            CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n            CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n         END IF\n\n         CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n     &        V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n*\n*           Permute the rows of V using the (column) permutation from the\n*           first QRF. Also, scale the columns to make them unit in\n*           Euclidean norm. This applies to all cases.\n*\n            TEMP1 = DSQRT(DBLE(N)) * EPSLN\n            DO 7972 q = 1, N\n               DO 8972 p = 1, N\n                  WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)\n 8972          CONTINUE\n               DO 8973 p = 1, N\n                  V(p,q) = WORK(2*N+N*NR+NR+p)\n 8973          CONTINUE\n               XSC = ONE / DNRM2( N, V(1,q), 1 )\n               IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n     &           CALL DSCAL( N, XSC, V(1,q), 1 )\n 7972       CONTINUE\n*\n*           At this moment, V contains the right singular vectors of A.\n*           Next, assemble the left singular vector matrix U (M x N).\n*\n         IF ( NR .LT. M ) THEN\n            CALL DLASET( 'A',  M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n            IF ( NR .LT. N1 ) THEN\n               CALL DLASET( 'A',NR,  N1-NR, ZERO, ZERO,  U(1,NR+1),LDU )\n               CALL DLASET( 'A',M-NR,N1-NR, ZERO, ONE,U(NR+1,NR+1),LDU )\n            END IF\n         END IF\n*\n         CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n     &        LDU, WORK(N+1), LWORK-N, IERR )\n*\n            IF ( ROWPIV )\n     &         CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n*\n         END IF\n         IF ( TRANSP ) THEN\n*           .. swap U and V because the procedure worked on A^t\n            DO 6974 p = 1, N\n               CALL DSWAP( N, U(1,p), 1, V(1,p), 1 )\n 6974       CONTINUE\n         END IF\n*\n      END IF\n*     end of the full SVD\n*\n*     Undo scaling, if necessary (and possible)\n*\n      IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN\n         CALL DLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR )\n         USCAL1 = ONE\n         USCAL2 = ONE\n      END IF\n*\n      IF ( NR .LT. N ) THEN\n         DO 3004 p = NR+1, N\n            SVA(p) = ZERO\n 3004    CONTINUE\n      END IF\n*\n      WORK(1) = USCAL2 * SCALEM\n      WORK(2) = USCAL1\n      IF ( ERREST ) WORK(3) = SCONDA\n      IF ( LSVEC .AND. RSVEC ) THEN\n         WORK(4) = CONDR1\n         WORK(5) = CONDR2\n      END IF\n      IF ( L2TRAN ) THEN\n         WORK(6) = ENTRA\n         WORK(7) = ENTRAT\n      END IF\n*\n      IWORK(1) = NR\n      IWORK(2) = NUMRANK\n      IWORK(3) = WARNING\n*\n      RETURN\n*     ..\n*     .. END OF DGEJSV\n*     ..\n      END\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  sva, u, v, iwork, info, work = NumRu::Lapack.dgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 9 && argc != 10)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+  rblapack_joba = argv[0];
+  rblapack_jobu = argv[1];
+  rblapack_jobv = argv[2];
+  rblapack_jobr = argv[3];
+  rblapack_jobt = argv[4];
+  rblapack_jobp = argv[5];
+  rblapack_m = argv[6];
+  rblapack_a = argv[7];
+  rblapack_work = argv[8];
+  if (argc == 10) {
+    rblapack_lwork = argv[9];
+  } else if (rblapack_options != Qnil) {
+    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+  } else {
+    rblapack_lwork = Qnil;
+  }
+
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (8th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  n = NA_SHAPE1(rblapack_a);
+  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, doublereal*);
+  m = NUM2INT(rblapack_m);
+  jobu = StringValueCStr(rblapack_jobu)[0];
+  jobv = StringValueCStr(rblapack_jobv)[0];
+  ldu = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? m : 1;
+  if (!NA_IsNArray(rblapack_work))
+    rb_raise(rb_eArgError, "work (9th argument) must be NArray");
+  if (NA_RANK(rblapack_work) != 1)
+    rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
+  lwork = NA_SHAPE0(rblapack_work);
+  if (NA_TYPE(rblapack_work) != NA_DFLOAT)
+    rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
+  work = NA_PTR_TYPE(rblapack_work, doublereal*);
+  jobr = StringValueCStr(rblapack_jobr)[0];
+  if (rblapack_lwork == Qnil)
+    lwork = (lsame_(&jobu,"N")&&lsame_(&jobv,"N")) ? MAX(MAX(2*m+n,4*n+n*n),7) : lsame_(&jobv,"V") ? MAX(2*n+m,7) : ((lsame_(&jobu,"U")||lsame_(&jobu,"F"))&&lsame_(&jobv,"V")) ? MAX(MAX(6*n+2*n*n,m+3*n+n*n),7) : MAX(2*n+m,7);
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  ldv = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? n : 1;
+  jobt = StringValueCStr(rblapack_jobt)[0];
+  jobp = StringValueCStr(rblapack_jobp)[0];
+  joba = StringValueCStr(rblapack_joba)[0];
+  {
+    int shape[1];
+    shape[0] = n;
+    rblapack_sva = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  sva = NA_PTR_TYPE(rblapack_sva, doublereal*);
+  {
+    int shape[2];
+    shape[0] = ldu;
+    shape[1] = n;
+    rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  u = NA_PTR_TYPE(rblapack_u, doublereal*);
+  {
+    int shape[2];
+    shape[0] = ldv;
+    shape[1] = n;
+    rblapack_v = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  v = NA_PTR_TYPE(rblapack_v, doublereal*);
+  {
+    int shape[1];
+    shape[0] = m+3*n;
+    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+  }
+  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+  {
+    int shape[1];
+    shape[0] = lwork;
+    rblapack_work_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  work_out__ = NA_PTR_TYPE(rblapack_work_out__, doublereal*);
+  MEMCPY(work_out__, work, doublereal, NA_TOTAL(rblapack_work));
+  rblapack_work = rblapack_work_out__;
+  work = work_out__;
+
+  dgejsv_(&joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a, &lda, sva, u, &ldu, v, &ldv, work, &lwork, iwork, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(6, rblapack_sva, rblapack_u, rblapack_v, rblapack_iwork, rblapack_info, rblapack_work);
+}
+
+void
+init_lapack_dgejsv(VALUE mLapack){
+  rb_define_module_function(mLapack, "dgejsv", rblapack_dgejsv, -1);
+}

data/ext/dgelq2.c

@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dgelq2_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgelq2(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_tau;
+  doublereal *tau; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_a_out__;
+  doublereal *a_out__;
+  doublereal *work;
+
+  integer lda;
+  integer n;
+  integer m;
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  tau, info, a = NumRu::Lapack.dgelq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGELQ2 computes an LQ factorization of a real m by n matrix A:\n*  A = L * Q.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, the elements on and below the diagonal of the array\n*          contain the m by min(m,n) lower trapezoidal matrix L (L is\n*          lower triangular if m <= n); the elements above the diagonal,\n*          with the array TAU, represent the orthogonal matrix Q as a\n*          product of elementary reflectors (see Further Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument had an illegal value\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrix Q is represented as a product of elementary reflectors\n*\n*     Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a real scalar, and v is a real vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),\n*  and tau in TAU(i).\n*\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  tau, info, a = NumRu::Lapack.dgelq2( a, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 1 && argc != 1)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+  rblapack_a = argv[0];
+  if (argc == 1) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (1th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  n = NA_SHAPE1(rblapack_a);
+  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, doublereal*);
+  m = lda;
+  {
+    int shape[1];
+    shape[0] = MIN(m,n);
+    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+  {
+    int shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*);
+  MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a));
+  rblapack_a = rblapack_a_out__;
+  a = a_out__;
+  work = ALLOC_N(doublereal, (m));
+
+  dgelq2_(&m, &n, a, &lda, tau, work, &info);
+
+  free(work);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgelq2(VALUE mLapack){
+  rb_define_module_function(mLapack, "dgelq2", rblapack_dgelq2, -1);
+}

data/ext/dgelqf.c

@@ -0,0 +1,99 @@
+#include "rb_lapack.h"
+
+extern VOID dgelqf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgelqf(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_m;
+  integer m; 
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_tau;
+  doublereal *tau; 
+  VALUE rblapack_work;
+  doublereal *work; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_a_out__;
+  doublereal *a_out__;
+
+  integer lda;
+  integer n;
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  tau, work, info, a = NumRu::Lapack.dgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGELQF computes an LQ factorization of a real M-by-N matrix A:\n*  A = L * Q.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the elements on and below the diagonal of the array\n*          contain the m-by-min(m,n) lower trapezoidal matrix L (L is\n*          lower triangular if m <= n); the elements above the diagonal,\n*          with the array TAU, represent the orthogonal matrix Q as a\n*          product of elementary reflectors (see Further Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.  LWORK >= max(1,M).\n*          For optimum performance LWORK >= M*NB, where NB is the\n*          optimal blocksize.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal size of the WORK array, returns\n*          this value as the first entry of the WORK array, and no error\n*          message related to LWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrix Q is represented as a product of elementary reflectors\n*\n*     Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a real scalar, and v is a real vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),\n*  and tau in TAU(i).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n     $                   NBMIN, NX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DGELQ2, DLARFB, DLARFT, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  tau, work, info, a = NumRu::Lapack.dgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 2 && argc != 3)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+  rblapack_m = argv[0];
+  rblapack_a = argv[1];
+  if (argc == 3) {
+    rblapack_lwork = argv[2];
+  } else if (rblapack_options != Qnil) {
+    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+  } else {
+    rblapack_lwork = Qnil;
+  }
+
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (2th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  n = NA_SHAPE1(rblapack_a);
+  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, doublereal*);
+  m = NUM2INT(rblapack_m);
+  if (rblapack_lwork == Qnil)
+    lwork = m;
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  {
+    int shape[1];
+    shape[0] = MIN(m,n);
+    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+  {
+    int shape[1];
+    shape[0] = MAX(1,lwork);
+    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  work = NA_PTR_TYPE(rblapack_work, doublereal*);
+  {
+    int shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*);
+  MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a));
+  rblapack_a = rblapack_a_out__;
+  a = a_out__;
+
+  dgelqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgelqf(VALUE mLapack){
+  rb_define_module_function(mLapack, "dgelqf", rblapack_dgelqf, -1);
+}

data/ext/dgels.c

@@ -0,0 +1,133 @@
+#include "rb_lapack.h"
+
+extern VOID dgels_(char* trans, integer* m, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgels(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_trans;
+  char trans; 
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_b;
+  doublereal *b; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_work;
+  doublereal *work; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_a_out__;
+  doublereal *a_out__;
+  VALUE rblapack_b_out__;
+  doublereal *b_out__;
+
+  integer lda;
+  integer n;
+  integer m;
+  integer nrhs;
+  integer ldb;
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  work, info, a, b = NumRu::Lapack.dgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGELS solves overdetermined or underdetermined real linear systems\n*  involving an M-by-N matrix A, or its transpose, using a QR or LQ\n*  factorization of A.  It is assumed that A has full rank.\n*\n*  The following options are provided:\n*\n*  1. If TRANS = 'N' and m >= n:  find the least squares solution of\n*     an overdetermined system, i.e., solve the least squares problem\n*                  minimize || B - A*X ||.\n*\n*  2. If TRANS = 'N' and m < n:  find the minimum norm solution of\n*     an underdetermined system A * X = B.\n*\n*  3. If TRANS = 'T' and m >= n:  find the minimum norm solution of\n*     an undetermined system A**T * X = B.\n*\n*  4. If TRANS = 'T' and m < n:  find the least squares solution of\n*     an overdetermined system, i.e., solve the least squares problem\n*                  minimize || B - A**T * X ||.\n*\n*  Several right hand side vectors b and solution vectors x can be\n*  handled in a single call; they are stored as the columns of the\n*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n*  matrix X.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': the linear system involves A;\n*          = 'T': the linear system involves A**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of\n*          columns of the matrices B and X. NRHS >=0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*            if M >= N, A is overwritten by details of its QR\n*                       factorization as returned by DGEQRF;\n*            if M <  N, A is overwritten by details of its LQ\n*                       factorization as returned by DGELQF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the matrix B of right hand side vectors, stored\n*          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS\n*          if TRANS = 'T'.\n*          On exit, if INFO = 0, B is overwritten by the solution\n*          vectors, stored columnwise:\n*          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least\n*          squares solution vectors; the residual sum of squares for the\n*          solution in each column is given by the sum of squares of\n*          elements N+1 to M in that column;\n*          if TRANS = 'N' and m < n, rows 1 to N of B contain the\n*          minimum norm solution vectors;\n*          if TRANS = 'T' and m >= n, rows 1 to M of B contain the\n*          minimum norm solution vectors;\n*          if TRANS = 'T' and m < n, rows 1 to M of B contain the\n*          least squares solution vectors; the residual sum of squares\n*          for the solution in each column is given by the sum of\n*          squares of elements M+1 to N in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= MAX(1,M,N).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          LWORK >= max( 1, MN + max( MN, NRHS ) ).\n*          For optimal performance,\n*          LWORK >= max( 1, MN + max( MN, NRHS )*NB ).\n*          where MN = min(M,N) and NB is the optimum block size.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal size of the WORK array, returns\n*          this value as the first entry of the WORK array, and no error\n*          message related to LWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  if INFO =  i, the i-th diagonal element of the\n*                triangular factor of A is zero, so that A does not have\n*                full rank; the least squares solution could not be\n*                computed.\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  work, info, a, b = NumRu::Lapack.dgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 3 && argc != 4)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+  rblapack_trans = argv[0];
+  rblapack_a = argv[1];
+  rblapack_b = argv[2];
+  if (argc == 4) {
+    rblapack_lwork = argv[3];
+  } else if (rblapack_options != Qnil) {
+    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+  } else {
+    rblapack_lwork = Qnil;
+  }
+
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (2th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  n = NA_SHAPE1(rblapack_a);
+  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, doublereal*);
+  trans = StringValueCStr(rblapack_trans)[0];
+  m = lda;
+  ldb = MAX(m,n);
+  if (!NA_IsNArray(rblapack_b))
+    rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 2)
+    rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+  if (NA_SHAPE0(rblapack_b) != m)
+    rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+  nrhs = NA_SHAPE1(rblapack_b);
+  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, doublereal*);
+  if (rblapack_lwork == Qnil)
+    lwork = MIN(m,n) + MAX(MIN(m,n),nrhs);
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  {
+    int shape[1];
+    shape[0] = MAX(1,lwork);
+    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  work = NA_PTR_TYPE(rblapack_work, doublereal*);
+  {
+    int shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*);
+  MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a));
+  rblapack_a = rblapack_a_out__;
+  a = a_out__;
+  {
+    int shape[2];
+    shape[0] = MAX(m, n);
+    shape[1] = nrhs;
+    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+  {
+    VALUE __shape__[3];
+    __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+    __shape__[1] = Qtrue;
+    __shape__[2] = rblapack_b;
+    na_aset(3, __shape__, rblapack_b_out__);
+  }
+  rblapack_b = rblapack_b_out__;
+  b = b_out__;
+
+  dgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
+
+  rblapack_info = INT2NUM(info);
+  {
+    VALUE __shape__[2];
+    __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+    __shape__[1] = Qtrue;
+    rblapack_b = na_aref(2, __shape__, rblapack_b);
+  }
+  return rb_ary_new3(4, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dgels(VALUE mLapack){
+  rb_define_module_function(mLapack, "dgels", rblapack_dgels, -1);
+}